home *** CD-ROM | disk | FTP | other *** search
/ Freelog 22 / freelog 22.iso / Prog / Djgpp / GPC2952B.ZIP / lib / gcc-lib / djgpp / 2.952 / units / gpc-bp.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-02-08  |  102.8 KB  |  3,524 lines
  1. {
  2. This unit implements some features found in Standard Pascal,
  3. Extended Pascal and GNU Pascal for Borland Pascal. It is meant as a
  4. help for gradually converting BP programs to GPC, while maintaining
  5. the ability to compile them with BP as long as possible, e.g., to
  6. compare their behaviour under BP and GPC. It is NOT meant as yet
  7. another BP extension unit for programs that are not intended to be
  8. compiled with GPC. Therefore, this unit comes as part of the GPC
  9. package. Besides, since the interface of some of GPC's routines can
  10. change, and this unit will be changed accordingly, it is not
  11. reasonable at this point of time to distribute this unit separately
  12. from GPC.
  13.  
  14. IMPORTANT NOTE: This unit is distributed under the GNU GPL. Please
  15. read the file COPYING for the exact terms of the GPL. In short, the
  16. GPL says that you must distribute any code that uses this unit under
  17. the GPL as well, which means that you have to make the source code
  18. available whenever you distribute a binary of the code, and that you
  19. must allow recipients to modify the code and redistribute it under
  20. the GPL. However, if you compile your code with GPC, it will not use
  21. this unit, but rather GPC's own units which, if compiled with a GNU
  22. compiler, do not cause the resulting executable to be covered by the
  23. GNU General Public License, so you can, e.g., distribute programs
  24. compiled with GPC as binaries without making available their source
  25. code if you respect the other relevant licenses.
  26.  
  27. This units provides a little bit of GPC compatibility for BP, and
  28. removes some silly restrictions of BP (e.g., the fixed string sizes
  29. in FSplit, or having to call SwapVectors and make available the free
  30. memory explicitly before/after calling Exec), but of course not the
  31. really bad ones (like the 64 KB limit, or the 255 characters limit
  32. for strings, or the 0..255 limit for sets). Some routines here have
  33. restrictions that are not present in GPC (e.g., the Min and Max
  34. functions here only work on integers while GPC's built-in Min and
  35. Max functions work on all ordinal types and real numbers). It does
  36. not emulate all GPC functions that could be emulated on BP, by far,
  37. and there are many GPC functions that cannot possibly be emulated on
  38. BP, so the usefulness of this unit is quite limited, and you will
  39. probably find that it's better to give up the ability to compile
  40. your code with BP after some time while you make sure that your code
  41. works as expected with GPC. The purpose of this unit is to fill in
  42. this time.
  43.  
  44. How to use this unit:
  45.  
  46. - Install: Copy this file to gpc.pas in a unit directory that is
  47.   searched by BP, but NOT by GPC (e.g. c:\bp\units, if you have
  48.   installed BP in c:\bp). When you get a new release of GPC, don't
  49.   forget to install the new version of this unit that comes with it.
  50.   If you are using BP on a real file system (e.g. Linux with
  51.   DosEmu), you can set symlinks to the files installed with GPC once
  52.   and for all, but on a Dos file system, you'll have to copy the
  53.   files after each GPC release.
  54.  
  55. - Use: In your code, simply add a `uses GPC' statement (which will
  56.   also work under GPC, but use GPC's own GPC unit then). If you use
  57.   any of the Strings, Dos and/or CRT units, use those units BEFORE
  58.   the GPC unit, since this unit overwrites some of those units'
  59.   routines.
  60.  
  61. Copyright (C) 1998-2001 Free Software Foundation, Inc.
  62.  
  63. Author: Frank Heckenbach <frank@pascal.gnu.de>
  64.  
  65. This file is part of GNU Pascal.
  66.  
  67. GNU Pascal is free software; you can redistribute it and/or modify
  68. it under the terms of the GNU General Public License as published by
  69. the Free Software Foundation; either version 2, or (at your option)
  70. any later version.
  71.  
  72. GNU Pascal is distributed in the hope that it will be useful,
  73. but WITHOUT ANY WARRANTY; without even the implied warranty of
  74. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  75. GNU General Public License for more details.
  76.  
  77. You should have received a copy of the GNU General Public License
  78. along with GNU Pascal; see the file COPYING. If not, write to the
  79. Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  80. 02111-1307, USA.
  81.  
  82. As a special exception, if you link this file with files compiled
  83. with a GNU compiler to produce an executable, this does not cause
  84. the resulting executable to be covered by the GNU General Public
  85. License. This exception does not however invalidate any other
  86. reasons why the executable file might be covered by the GNU General
  87. Public License.
  88. }
  89.  
  90. {$ifdef __GPC__}
  91. {$error This unit is meant to provide GPC compatibility for BP.
  92. GPC does not need this unit. If GPC tries to use it, you have
  93. installed it in a wrong place. Please install it in a unit
  94. directory that is searched by BP, but not by GPC.}
  95. {$endif}
  96.  
  97. {$ifndef VER70} This unit is only for TP/BP 7.0 {$endif}
  98.  
  99. {$B-,I-,A+,F+,N+}
  100.  
  101. unit GPC;
  102.  
  103. interface
  104.  
  105. uses Strings, Dos, CRT;
  106.  
  107. { System extensions }
  108.  
  109. const
  110.   BitsBigEndian          = False;
  111.   BytesBigEndian         = False;
  112.   WordsBigEndian         = False;
  113.   NeedAlignment          = False;
  114.  
  115.   MaxVarSize             = $fff0;
  116.   Binding_Name_Length    = High (PathStr);
  117.  
  118.   SpaceCharacters        = [' ', #9];
  119.  
  120.   OSDosFlag              = True;
  121.   QuotingCharacter       = #0;
  122.   PathSeparator          = ';';
  123.   DirSeparator           = '\';
  124.   DirSeparators          = [':', '\'];
  125.   ExtSeparator           = '.';
  126.   DirRoot                = '\';
  127.   DirSelf                = '.';
  128.   DirParent              = '..';
  129.   NullDeviceName         = 'nul';
  130.   TTYDeviceName          = 'con';
  131.   ConsoleDeviceName      = 'con';
  132.   EnvVarCharsFirst       = ['A' .. 'Z', 'a' .. 'z', '_'];
  133.   EnvVarChars            = EnvVarCharsFirst + ['0' .. '9'];
  134.   PathEnvVar             = 'PATH';
  135.   ShellEnvVar            = 'COMSPEC';
  136.   ShellExecCommand       = '/c';
  137.   ConfigFileMask         = '*.cfg';
  138.   FileNamesCaseSensitive = False;
  139.  
  140.   NewLine = #13#10;
  141.   LineBreak = #13#10;
  142.   WildCardChars = ['*', '?', '[', ']'];
  143.   FileNameSpecialChars = (WildCardChars + SpaceCharacters + ['{', '}', '$', QuotingCharacter]) - DirSeparators;
  144.  
  145.   HeapErrorRunError = 0;
  146.   HeapErrorNil      = 1;
  147.   HeapErrorRetry    = 2;
  148.  
  149.   DayOfWeekName : array [0 .. 6] of String [9] =
  150.     ('Sunday', 'Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday');
  151.  
  152.   MonthName : array [1 .. 12] of String [9] =
  153.     ('January', 'February', 'March', 'April', 'May', 'June',
  154.      'July', 'August', 'September', 'October', 'November', 'December');
  155.  
  156.   { File mode constants that are ORed for BindingType.Mode and ChMod. }
  157.   fm_SetUID           = 2048;
  158.   fm_SetGID           = 1024;
  159.   fm_Sticky           = 512;
  160.   fm_UserReadable     = 256;
  161.   fm_UserWritable     = 128;
  162.   fm_UserExecutable   = 64;
  163.   fm_GroupReadable    = 32;
  164.   fm_GroupWritable    = 16;
  165.   fm_GroupExecutable  = 8;
  166.   fm_OthersReadable   = 4;
  167.   fm_OthersWritable   = 2;
  168.   fm_OthersExecutable = 1;
  169.  
  170. type
  171.   TChars      = packed array [1 .. MaxVarSize div SizeOf (Char)] of Char;
  172.   PChars      = ^TChars;
  173.   CString     = PChar;
  174.   PCStrings   = ^TCStrings;
  175.   TCStrings   = array [0 .. MaxVarSize div SizeOf (CString) - 1] of CString;
  176.   TString     = String;
  177.   PString     = ^String;
  178.   CharSet     = set of Char;
  179.   Cardinal    = Word;
  180.   ByteInt     = ShortInt;
  181.   ByteCard    = Byte;
  182.   ShortWord   = Byte;
  183.   ShortCard   = ShortWord;
  184.   MedInt      = Integer;
  185.   MedWord     = Word;
  186.   MedCard     = Word;
  187.   LongWord    = LongInt; { Not available as an unsigned integer in BP }
  188.   LongCard    = LongWord;
  189.   LongestInt  = LongInt;
  190.   LongestWord = LongWord;
  191.   LongestCard = LongCard;
  192.   SizeType    = Word;
  193.   PtrDiffType = Word;
  194.   PtrInt      = LongInt;
  195.   PtrWord     = LongWord;
  196.   PtrCard     = LongCard;
  197.   DirPtr      = ^SearchRec;
  198.  
  199.   AnyFile     = Text;
  200.   PAnyFile    = ^AnyFile;
  201.  
  202.   TimeStamp = packed record
  203.     DateValid,
  204.     TimeValid   : Boolean;
  205.     Year        : Integer;
  206.     Month       : 1 .. 12;
  207.     Day         : 1 .. 31;
  208.     DayOfWeek   : 0 .. 6;  { 0 means Sunday }
  209.     Hour        : 0 .. 23;
  210.     Minute      : 0 .. 59;
  211.     Second      : 0 .. 61;
  212.     MicroSecond : 0 .. 999999
  213.   end;
  214.  
  215.   FileSizeType = LongInt;
  216.   UnixTimeType = LongInt;
  217.   MicroSecondTimeType = Comp;
  218.  
  219.   BindingType = packed record
  220.     Bound             : Boolean;
  221.     Force             : Boolean;      { Ignored }
  222.     Extensions_Valid  : Boolean;
  223.     Readable          : Boolean;
  224.     Writable          : Boolean;
  225.     Executable        : Boolean;
  226.     Existing          : Boolean;
  227.     Directory         : Boolean;
  228.     Special           : Boolean;
  229.     SymLink           : Boolean;
  230.     Size              : FileSizeType;
  231.     AccessTime,                       { These times are Unix times (seconds since 1970-01-01, 00:00:00), }
  232.     ModificationTime,                 { but relative to the current time zone (unlike Unix time) because }
  233.     ChangeTime        : UnixTimeType; { time zone information is not generally available under Dos. }
  234.     User,                             { Dummy }
  235.     Group,                            { Dummy }
  236.     Mode,                             { Access permissions }
  237.     Device,                           { Device the file is on }
  238.     INode             : Integer;      { Dummy }
  239.     TextBinary        : Boolean;      { Does nothing! Implementing it would take a TFDD to do the conversion,
  240.                                         and overwritten Reset, Rewrite and Append procedures for text files,
  241.                                         but those would conflict with the built-in ones for typed and untyped
  242.                                         files, and I don't think it's worth that effort to support an
  243.                                         obsolete compiler. }
  244.     Handle            : Integer;      { Ignored }
  245.     Name              : String [Binding_Name_Length]
  246.   end;
  247.  
  248. var
  249.   Null : Integer absolute 0 : 0; { Only Integer }
  250.   StdErr : Text;
  251.  
  252. { Only for Integers }
  253. function  Min (a, b : Integer) : Integer;
  254. function  Max (a, b : Integer) : Integer;
  255.  
  256. function  InPortB  (PortNumber : Word) : Byte;
  257. function  InPortW  (PortNumber : Word) : Word;
  258. procedure OutPortB (PortNumber : Word; Val : Byte);
  259. procedure OutPortW (PortNumber, Val : Word);
  260.  
  261. { Dummies }
  262. function  IOPerm (From, Num : MedCard; On : Integer) : Integer;
  263. function  IOPL (Level : Integer) : Integer;
  264. function  SetEUID (EUID : Integer) : Integer;
  265.  
  266. function  UserID  (Effective : Boolean) : Integer;
  267. function  GroupID (Effective : Boolean) : Integer;
  268.  
  269. { Emulates malloc(), i.e. returns nil if not enough memory available }
  270. function  CGetMem (Size : SizeType) : Pointer;
  271.  
  272. function  HeapErrorNilReturn (Size : Word) : Integer;
  273.  
  274. function  MemComp (const s1, s2; Size : SizeType) : Integer;
  275.  
  276. { Uniform access to big memory blocks for GPC and BP. See GPC's GPCUtil
  277.   unit. In real mode, these routines will try to use XMS and EMS to
  278.   provide access to as much memory as possible. }
  279.  
  280. type
  281.   PBigMem = ^TBigMem;
  282.   TBigMem = record
  283.     { Public fields }
  284.     Number, BlockSize : SizeType;
  285.     Mappable : Boolean;
  286.     { Private fields }
  287.     {$ifdef MSDOS}
  288.     XMSHandle, EMSHandle, XMSKBPerBlock, EMSPagesPerBlock, XMSBlocks, EMSBlocks,
  289.     {$endif}
  290.     ConventionalBlocks : Word;
  291.     PConventional : array [1 .. $400] of Pointer
  292.   end;
  293.  
  294. { Note: the number of blocks actually allocated may be smaller than
  295.   WantedNumber. Check the Number field of the result. }
  296. function  AllocateBigMem (WantedNumber, aBlockSize : SizeType; WantMappable : Boolean) : PBigMem;
  297. procedure DisposeBigMem (p : PBigMem);
  298. procedure MoveToBigMem (var Source; p : PBigMem; BlockNumber : SizeType);
  299. procedure MoveFromBigMem (p : PBigMem; BlockNumber : SizeType; var Dest);
  300. { Maps a big memory block into normal addressable memory and returns its
  301.   address. The memory must have been allocated with WantMappable = True.
  302.   The mapping is only valid until the next MapBigMem call. }
  303. function  MapBigMem (p : PBigMem; BlockNumber : SizeType) : Pointer;
  304.  
  305. procedure ReverseBytes            (var Buf; ElementSize, Count : SizeType);
  306. procedure ConvertFromLittleEndian (var Buf; ElementSize, Count : SizeType);
  307. procedure ConvertFromBigEndian    (var Buf; ElementSize, Count : SizeType);
  308. procedure ConvertToLittleEndian   (var Buf; ElementSize, Count : SizeType);
  309. procedure ConvertToBigEndian      (var Buf; ElementSize, Count : SizeType);
  310.  
  311. procedure BlockReadLittleEndian   (var aFile : File; var   Buf; ElementSize, Count : SizeType);
  312. procedure BlockReadBigEndian      (var aFile : File; var   Buf; ElementSize, Count : SizeType);
  313. procedure BlockWriteLittleEndian  (var aFile : File; const Buf; ElementSize, Count : SizeType);
  314. procedure BlockWriteBigEndian     (var aFile : File; const Buf; ElementSize, Count : SizeType);
  315.  
  316. {$P+}
  317. procedure ReadStringLittleEndian  (var f : File; var s : String);
  318. procedure ReadStringBigEndian     (var f : File; var s : String);
  319. procedure WriteStringLittleEndian (var f : File; const s : String);
  320. procedure WriteStringBigEndian    (var f : File; const s : String);
  321. {$P-}
  322.  
  323. function  NewString (const s : String) : PString;
  324. procedure DisposeString (p : PString);
  325. function  IsUpCase             (ch : Char) : Boolean;
  326. function  IsLoCase             (ch : Char) : Boolean;
  327. function  IsAlphaNum           (ch : Char) : Boolean;
  328. function  IsAlphaNumUnderscore (ch : Char) : Boolean;
  329. function  IsPrintable          (ch : Char) : Boolean;
  330. function  UpCase (Ch : Char) : Char; { Overwrites System version -- handles some international characters }
  331. function  LoCase (Ch : Char) : Char;
  332. function  UpCaseStr (s : String) : String;
  333. function  LoCaseStr (s : String) : String;
  334. {$P+}
  335. procedure UpCaseString    (var s : String);
  336. procedure LoCaseString    (var s : String);
  337. procedure SetLength       (var s : String; NewLength : Integer);
  338. function  StringOfChar    (Ch : Char; Count : Integer) : TString;
  339. procedure TrimLeft        (var s : String);
  340. procedure TrimRight       (var s : String);
  341. procedure TrimBoth        (var s : String);
  342. function  TrimLeftStr     (s : String) : TString;
  343. function  TrimRightStr    (s : String) : TString;
  344. function  TrimBothStr     (s : String) : TString;
  345. function  GetStringCapacity (var s : String) : Integer; { NOTE: the parameter must be var (not const),
  346.                                                           otherwise BP gets the capacity wrong! }
  347. {$P-}
  348.  
  349. function  LastPos         (const SubStr, Str : String) : Integer;
  350. function  CharPos         (const Chars : CharSet; const Str : String) : Integer;
  351. function  LastCharPos     (const Chars : CharSet; const Str : String) : Integer;
  352.  
  353. function  PosFrom         (const SubStr, Str : String; From : Integer) : Integer;
  354. function  LastPosTill     (const SubStr, Str : String; Till : Integer) : Integer;
  355. function  CharPosFrom     (const Chars : CharSet; const Str : String; From : Integer) : Integer;
  356. function  LastCharPosTill (const Chars : CharSet; const Str : String; Till : Integer) : Integer;
  357.  
  358. function  IsPrefix     (const Prefix, s : String) : Boolean;
  359. function  IsSuffix     (const Suffix, s : String) : Boolean;
  360.  
  361. function  NewCString   (const Source : String) : CString;
  362.  
  363. function  Integer2String (i : Integer) : TString;
  364.  
  365. { Only for text files. This routine is rather ridiculous than a real
  366.   emulation, but it's good for a few things, like finding out if a
  367.   file is writable or getting its modification time. }
  368. procedure GetBinding (var f : Text; var aBinding : BindingType);
  369.  
  370. function  IsLeapYear (Year : Integer) : Boolean;
  371. function  MonthLength (Month, Year : Integer) : Integer;
  372. procedure Sleep (Seconds : Integer);
  373. procedure SleepMicroSeconds (MicroSeconds : LongInt);
  374. function  GetMicroSecondTime : MicroSecondTimeType;
  375. function  GetCPUTime (var MicroSecond { : LongInt }) : LongInt; { type of MicroSecond is omitted, so one can pass null }
  376.  
  377. function  AddDirSeparator    (s : String) : TString;
  378. function  RemoveDirSeparator (s : String) : TString;
  379. function  GetCurrentDirectory : TString;
  380. function  GetTempDirectory    : TString;
  381. function  ExpandEnvironment (var s : String) : Boolean;
  382. function  FileExists      (const aFileName : String) : Boolean;
  383. function  DirectoryExists (      aFileName : String) : Boolean;
  384. function  PathExists      (const aFileName : String) : Boolean;
  385. function  RelativePath    (const Path : String; OnlyCurDir, Quoted : Boolean) : TString;
  386. function  DirFromPath     (const Path : String) : TString;
  387. function  NameFromPath    (const Path : String) : TString;
  388. function  ExtFromPath     (const Path : String) : TString;
  389. function  NameExtFromPath (const Path : String) : TString;
  390. function  OpenDir  (Name : String) : DirPtr;
  391. function  ReadDir  (Dir : DirPtr) : TString;
  392. procedure CloseDir (Dir : DirPtr);
  393. function  HasWildCards (const s : String) : Boolean;
  394. function  FileNameMatch (const Pattern, Name : String) : Boolean;
  395. function  ConfigFileName (Prefix, Name : String; Global : Boolean) : TString;
  396. function  DataDirectoryName (Prefix, Name : String) : TString;
  397.  
  398. procedure GetTimeStamp (var aTimeStamp : TimeStamp);
  399.  
  400. procedure CheckInOutRes;
  401. function  GetIOErrorMessage : TString;
  402.  
  403. procedure Close     (var f : Text); { Overwrites System version -- does not cause an error if file was not open }
  404. procedure CloseFile (var f : File); { The same for untyped files -- can't be called `Close' as well :-( }
  405.  
  406. function  Execute (CmdLine : String) : Integer;
  407.  
  408. type
  409.   TProcedure = procedure;
  410.  
  411. procedure RegisterRestoreTerminal (ForAnotherProcess : Boolean; Proc : TProcedure);
  412. function  UnregisterRestoreTerminal (ForAnotherProcess : Boolean; Proc : TProcedure) : Boolean;
  413. procedure RestoreTerminal (ForAnotherProcess : Boolean);
  414.  
  415. { TFDD (interface is subject to change) }
  416.  
  417. type
  418.   TOpenMode   = (foReset, foRewrite, foAppend, foSeekRead, foSeekWrite, foSeekUpdate);
  419.   TOpenProc   = procedure (var PrivateData; Mode : TOpenMode);
  420.   TSelectFunc = function  (var PrivateData; Writing : Boolean) : Integer;
  421.   TSelectProc = procedure (var PrivateData; var ReadSelect, WriteSelect, ExceptSelect : Boolean);
  422.   TReadFunc   = function  (var PrivateData; var   Buffer; Size : SizeType) : SizeType;
  423.   TWriteFunc  = function  (var PrivateData; const Buffer; Size : SizeType) : SizeType;
  424.   TFileProc   = procedure (var PrivateData);
  425.   TFlushProc  = TFileProc;
  426.   TCloseProc  = TFileProc;
  427.   TDoneProc   = TFileProc;
  428.  
  429. procedure AssignTFDD (var f : AnyFile;
  430.                       OpenProc    : TOpenProc;
  431.                       SelectFunc  : TSelectFunc; { will not be called in BP! }
  432.                       SelectProc  : TSelectProc; { will not be called in BP! }
  433.                       ReadFunc    : TReadFunc;
  434.                       WriteFunc   : TWriteFunc;
  435.                       FlushProc   : TFlushProc;
  436.                       CloseProc   : TCloseProc;
  437.                       DoneProc    : TDoneProc;   { will not be called in BP! }
  438.                       PrivateData : Pointer);
  439.  
  440. { Strings extensions }
  441.  
  442. function CString2String (Str : CString) : TString;
  443.  
  444. { Printer extensions }
  445.  
  446. procedure AssignLst (var f : Text);
  447.  
  448. { GetOpt -- very primitive }
  449.  
  450. const
  451.   EndOfOptions      = #255;
  452.   NoOption          = #1;
  453.   UnknownOption     = '?';
  454.   LongOption        = #0;
  455.   UnknownLongOption = '?';
  456.  
  457.   FirstNonOption         : Integer = 0;
  458.   HasOptionArgument      : Boolean = False;
  459.   OptionArgument         : TString = '';
  460.   UnknownOptionCharacter : Char    = '?';
  461.   GetOptErrorFlag        : Boolean = True;
  462.  
  463. function GetOpt (OptString : CString) : Char;
  464.  
  465. { Dos extensions }
  466.  
  467. type
  468.   TDosAttr = Word;
  469.  
  470. const
  471.   { DosError codes }
  472.   DosError_FileNotFound = 2;
  473.   DosError_PathNotFound = 3;
  474.   DosError_AccessDenied = 5;
  475.   DosError_InvalidMem   = 9;
  476.   DosErorr_InvalidEnv   = 10;
  477.   DosError_NoMoreFiles  = 18;
  478.   DosError_IOError      = 29;
  479.   DosError_ReadFault    = 30;
  480.  
  481. procedure FindFirst (const Path : String; Attr : Word; var SR : SearchRec); { Overwrites Dos version -- see FindNext }
  482. procedure FindNext  (var SR : SearchRec); { Overwrites Dos version -- transforms resulting file name to lower case }
  483. procedure FindClose (var SR : SearchRec); { Does nothing }
  484. function  FExpand   (const Path : String) : TString; { Overwrites Dos version -- transforms result to lower case,
  485.                                                        removes trailing `.' when necessary. Returns '' if nonexistent path. }
  486. {$P+}
  487. procedure FSplit (const Path : String; var Dir, Name, Ext : String); { Overwrites Dos version -- accepts strings of any size }
  488. {$P-}
  489. function  GetEnv (const EnvVar : String) : TString; { Repeats Dos version }
  490. procedure SwapVectors; { Overwrites Dos version -- does nothing }
  491. procedure Exec (const Path, ComLine : String); { Overwrites Dos version -- does SwapVectors automatically, calls
  492.                                                  RestoreTerminal, frees up some conventional memory space if
  493.                                                  possible (in real mode) }
  494.  
  495. { CRT extensions }
  496.  
  497. type
  498.   TTextAttr = Byte;
  499.  
  500. procedure CRTInit;
  501. function  KeyPressed : Boolean; { Overwrites CRT version -- see ReadKey }
  502. function  ReadKey : Char; { Overwrites CRT version -- handles Shift-Insert and Shift-Delete }
  503. procedure TextMode (Mode : Integer); { Overwrites CRT version -- updates some internal data }
  504.  
  505. { Keyboard and character graphics constants, from GPC's crt.inc }
  506. const
  507.   ksUnknown    = #255;     kbUnknown    = $100 * Ord (ksUnknown);
  508.   ksLeft       = #75;      kbLeft       = $100 * Ord (ksLeft);
  509.   ksRight      = #77;      kbRight      = $100 * Ord (ksRight);
  510.   ksUp         = #72;      kbUp         = $100 * Ord (ksUp);
  511.   ksDown       = #80;      kbDown       = $100 * Ord (ksDown);
  512.   ksPgUp       = #73;      kbPgUp       = $100 * Ord (ksPgUp);
  513.   ksPgDn       = #81;      kbPgDn       = $100 * Ord (ksPgDn);
  514.   ksHome       = #71;      kbHome       = $100 * Ord (ksHome);
  515.   ksEnd        = #79;      kbEnd        = $100 * Ord (ksEnd);
  516.   ksIns        = #82;      kbIns        = $100 * Ord (ksIns);
  517.   ksDel        = #83;      kbDel        = $100 * Ord (ksDel);
  518.   ksCenter     = #76;      kbCenter     = $100 * Ord (ksCenter);
  519.   ksShTab      = #15;      kbShTab      = $100 * Ord (ksShTab);
  520.   ksShIns      = #246;     kbShIns      = $100 * Ord (ksShIns);
  521.   ksShDel      = #247;     kbShDel      = $100 * Ord (ksShDel);
  522.   ksCtrlTab    = #148;     kbCtrlTab    = $100 * Ord (ksCtrlTab);
  523.   ksCtrlLeft   = #115;     kbCtrlLeft   = $100 * Ord (ksCtrlLeft);
  524.   ksCtrlRight  = #116;     kbCtrlRight  = $100 * Ord (ksCtrlRight);
  525.   ksCtrlUp     = #141;     kbCtrlUp     = $100 * Ord (ksCtrlUp);
  526.   ksCtrlDown   = #145;     kbCtrlDown   = $100 * Ord (ksCtrlDown);
  527.   ksCtrlPgUp   = #132;     kbCtrlPgUp   = $100 * Ord (ksCtrlPgUp);
  528.   ksCtrlPgDn   = #118;     kbCtrlPgDn   = $100 * Ord (ksCtrlPgDn);
  529.   ksCtrlHome   = #119;     kbCtrlHome   = $100 * Ord (ksCtrlHome);
  530.   ksCtrlEnd    = #117;     kbCtrlEnd    = $100 * Ord (ksCtrlEnd);
  531.   ksCtrlIns    = #146;     kbCtrlIns    = $100 * Ord (ksCtrlIns);
  532.   ksCtrlDel    = #147;     kbCtrlDel    = $100 * Ord (ksCtrlDel);
  533.   ksCtrlCentr  = #143;     kbCtrlCentr  = $100 * Ord (ksCtrlCentr);
  534.   ksAltTab     = #165;     kbAltTab     = $100 * Ord (ksAltTab);
  535.   ksAltLeft    = #155;     kbAltLeft    = $100 * Ord (ksAltLeft);
  536.   ksAltRight   = #157;     kbAltRight   = $100 * Ord (ksAltRight);
  537.   ksAltUp      = #152;     kbAltUp      = $100 * Ord (ksAltUp);
  538.   ksAltDown    = #160;     kbAltDown    = $100 * Ord (ksAltDown);
  539.   ksAltPgUp    = #153;     kbAltPgUp    = $100 * Ord (ksAltPgUp);
  540.   ksAltPgDn    = #161;     kbAltPgDn    = $100 * Ord (ksAltPgDn);
  541.   ksAltHome    = #151;     kbAltHome    = $100 * Ord (ksAltHome);
  542.   ksAltEnd     = #159;     kbAltEnd     = $100 * Ord (ksAltEnd);
  543.   ksAltIns     = #162;     kbAltIns     = $100 * Ord (ksAltIns);
  544.   ksAltDel     = #163;     kbAltDel     = $100 * Ord (ksAltDel);
  545.   ksAltEnter   = #166;     kbAltEnter   = $100 * Ord (ksAltEnter);
  546.   ksAltPStar   = #55;      kbAltPStar   = $100 * Ord (ksAltPStar);
  547.   ksAltPMinus  = #74;      kbAltPMinus  = $100 * Ord (ksAltPMinus);
  548.   ksAltPPlus   = #78;      kbAltPPlus   = $100 * Ord (ksAltPPlus);
  549.   ksAltEsc     = #1;       kbAltEsc     = $100 * Ord (ksAltEsc);
  550.   ksAltSpace   = #2;       kbAltSpace   = $100 * Ord (ksAltSpace);
  551.   ksAltBkSp    = #14;      kbAltBkSp    = $100 * Ord (ksAltBkSp);
  552.   ksAltMinus   = #130;     kbAltMinus   = $100 * Ord (ksAltMinus);
  553.   ksAltEqual   = #131;     kbAltEqual   = $100 * Ord (ksAltEqual);
  554.   ksAltLBrack  = #26;      kbAltLBrack  = $100 * Ord (ksAltLBrack);
  555.   ksAltRBrack  = #27;      kbAltRBrack  = $100 * Ord (ksAltRBrack);
  556.   ksAltSemic   = #39;      kbAltSemic   = $100 * Ord (ksAltSemic);
  557.   ksAltFQuote  = #40;      kbAltFQuote  = $100 * Ord (ksAltFQuote);
  558.   ksAltBQuote  = #41;      kbAltBQuote  = $100 * Ord (ksAltBQuote);
  559.   ksAltComma   = #51;      kbAltComma   = $100 * Ord (ksAltComma);
  560.   ksAltStop    = #52;      kbAltStop    = $100 * Ord (ksAltStop);
  561.   ksAltFSlash  = #53;      kbAltFSlash  = $100 * Ord (ksAltFSlash);
  562.   ksAltBSlash  = #43;      kbAltBSlash  = $100 * Ord (ksAltBslash);
  563.   ksAlt0       = #129;     kbAlt0       = $100 * Ord (ksAlt0);
  564.   ksAlt1       = #120;     kbAlt1       = $100 * Ord (ksAlt1);
  565.   ksAlt2       = #121;     kbAlt2       = $100 * Ord (ksAlt2);
  566.   ksAlt3       = #122;     kbAlt3       = $100 * Ord (ksAlt3);
  567.   ksAlt4       = #123;     kbAlt4       = $100 * Ord (ksAlt4);
  568.   ksAlt5       = #124;     kbAlt5       = $100 * Ord (ksAlt5);
  569.   ksAlt6       = #125;     kbAlt6       = $100 * Ord (ksAlt6);
  570.   ksAlt7       = #126;     kbAlt7       = $100 * Ord (ksAlt7);
  571.   ksAlt8       = #127;     kbAlt8       = $100 * Ord (ksAlt8);
  572.   ksAlt9       = #128;     kbAlt9       = $100 * Ord (ksAlt9);
  573.   ksAltA       = #30;      kbAltA       = $100 * Ord (ksAltA);
  574.   ksAltB       = #48;      kbAltB       = $100 * Ord (ksAltB);
  575.   ksAltC       = #46;      kbAltC       = $100 * Ord (ksAltC);
  576.   ksAltD       = #32;      kbAltD       = $100 * Ord (ksAltD);
  577.   ksAltE       = #18;      kbAltE       = $100 * Ord (ksAltE);
  578.   ksAltF       = #33;      kbAltF       = $100 * Ord (ksAltF);
  579.   ksAltG       = #34;      kbAltG       = $100 * Ord (ksAltG);
  580.   ksAltH       = #35;      kbAltH       = $100 * Ord (ksAltH);
  581.   ksAltI       = #23;      kbAltI       = $100 * Ord (ksAltI);
  582.   ksAltJ       = #36;      kbAltJ       = $100 * Ord (ksAltJ);
  583.   ksAltK       = #37;      kbAltK       = $100 * Ord (ksAltK);
  584.   ksAltL       = #38;      kbAltL       = $100 * Ord (ksAltL);
  585.   ksAltM       = #50;      kbAltM       = $100 * Ord (ksAltM);
  586.   ksAltN       = #49;      kbAltN       = $100 * Ord (ksAltN);
  587.   ksAltO       = #24;      kbAltO       = $100 * Ord (ksAltO);
  588.   ksAltP       = #25;      kbAltP       = $100 * Ord (ksAltP);
  589.   ksAltQ       = #16;      kbAltQ       = $100 * Ord (ksAltQ);
  590.   ksAltR       = #19;      kbAltR       = $100 * Ord (ksAltR);
  591.   ksAltS       = #31;      kbAltS       = $100 * Ord (ksAltS);
  592.   ksAltT       = #20;      kbAltT       = $100 * Ord (ksAltT);
  593.   ksAltU       = #22;      kbAltU       = $100 * Ord (ksAltU);
  594.   ksAltV       = #47;      kbAltV       = $100 * Ord (ksAltV);
  595.   ksAltW       = #17;      kbAltW       = $100 * Ord (ksAltW);
  596.   ksAltX       = #45;      kbAltX       = $100 * Ord (ksAltX);
  597.   ksAltY       = #21;      kbAltY       = $100 * Ord (ksAltY);
  598.   ksAltZ       = #44;      kbAltZ       = $100 * Ord (ksAltZ);
  599.   ksAltGr0     = #168;     kbAltGr0     = $100 * Ord (ksAltGr0);
  600.   ksAltGr1     = #169;     kbAltGr1     = $100 * Ord (ksAltGr1);
  601.   ksAltGr2     = #170;     kbAltGr2     = $100 * Ord (ksAltGr2);
  602.   ksAltGr3     = #171;     kbAltGr3     = $100 * Ord (ksAltGr3);
  603.   ksAltGr4     = #172;     kbAltGr4     = $100 * Ord (ksAltGr4);
  604.   ksAltGr5     = #173;     kbAltGr5     = $100 * Ord (ksAltGr5);
  605.   ksAltGr6     = #174;     kbAltGr6     = $100 * Ord (ksAltGr6);
  606.   ksAltGr7     = #175;     kbAltGr7     = $100 * Ord (ksAltGr7);
  607.   ksAltGr8     = #176;     kbAltGr8     = $100 * Ord (ksAltGr8);
  608.   ksAltGr9     = #177;     kbAltGr9     = $100 * Ord (ksAltGr9);
  609.   ksAltGrA     = #178;     kbAltGrA     = $100 * Ord (ksAltGrA);
  610.   ksAltGrB     = #179;     kbAltGrB     = $100 * Ord (ksAltGrB);
  611.   ksAltGrC     = #180;     kbAltGrC     = $100 * Ord (ksAltGrC);
  612.   ksAltGrD     = #181;     kbAltGrD     = $100 * Ord (ksAltGrD);
  613.   ksAltGrE     = #182;     kbAltGrE     = $100 * Ord (ksAltGrE);
  614.   ksAltGrF     = #183;     kbAltGrF     = $100 * Ord (ksAltGrF);
  615.   ksAltGrG     = #184;     kbAltGrG     = $100 * Ord (ksAltGrG);
  616.   ksAltGrH     = #185;     kbAltGrH     = $100 * Ord (ksAltGrH);
  617.   ksAltGrI     = #186;     kbAltGrI     = $100 * Ord (ksAltGrI);
  618.   ksAltGrJ     = #187;     kbAltGrJ     = $100 * Ord (ksAltGrJ);
  619.   ksAltGrK     = #188;     kbAltGrK     = $100 * Ord (ksAltGrK);
  620.   ksAltGrL     = #189;     kbAltGrL     = $100 * Ord (ksAltGrL);
  621.   ksAltGrM     = #190;     kbAltGrM     = $100 * Ord (ksAltGrM);
  622.   ksAltGrN     = #191;     kbAltGrN     = $100 * Ord (ksAltGrN);
  623.   ksAltGrO     = #192;     kbAltGrO     = $100 * Ord (ksAltGrO);
  624.   ksAltGrP     = #193;     kbAltGrP     = $100 * Ord (ksAltGrP);
  625.   ksAltGrQ     = #194;     kbAltGrQ     = $100 * Ord (ksAltGrQ);
  626.   ksAltGrR     = #195;     kbAltGrR     = $100 * Ord (ksAltGrR);
  627.   ksAltGrS     = #196;     kbAltGrS     = $100 * Ord (ksAltGrS);
  628.   ksAltGrT     = #197;     kbAltGrT     = $100 * Ord (ksAltGrT);
  629.   ksAltGrU     = #198;     kbAltGrU     = $100 * Ord (ksAltGrU);
  630.   ksAltGrV     = #199;     kbAltGrV     = $100 * Ord (ksAltGrV);
  631.   ksAltGrW     = #200;     kbAltGrW     = $100 * Ord (ksAltGrW);
  632.   ksAltGrX     = #201;     kbAltGrX     = $100 * Ord (ksAltGrX);
  633.   ksAltGrY     = #202;     kbAltGrY     = $100 * Ord (ksAltGrY);
  634.   ksAltGrZ     = #203;     kbAltGrZ     = $100 * Ord (ksAltGrZ);
  635.   ksExtra0     = #208;     kbExtra0     = $100 * Ord (ksExtra0);
  636.   ksExtra1     = #209;     kbExtra1     = $100 * Ord (ksExtra1);
  637.   ksExtra2     = #210;     kbExtra2     = $100 * Ord (ksExtra2);
  638.   ksExtra3     = #211;     kbExtra3     = $100 * Ord (ksExtra3);
  639.   ksExtra4     = #212;     kbExtra4     = $100 * Ord (ksExtra4);
  640.   ksExtra5     = #213;     kbExtra5     = $100 * Ord (ksExtra5);
  641.   ksExtra6     = #214;     kbExtra6     = $100 * Ord (ksExtra6);
  642.   ksExtra7     = #215;     kbExtra7     = $100 * Ord (ksExtra7);
  643.   ksExtra8     = #216;     kbExtra8     = $100 * Ord (ksExtra8);
  644.   ksExtra9     = #217;     kbExtra9     = $100 * Ord (ksExtra9);
  645.   ksExtraA     = #218;     kbExtraA     = $100 * Ord (ksExtraA);
  646.   ksExtraB     = #219;     kbExtraB     = $100 * Ord (ksExtraB);
  647.   ksExtraC     = #220;     kbExtraC     = $100 * Ord (ksExtraC);
  648.   ksExtraD     = #221;     kbExtraD     = $100 * Ord (ksExtraD);
  649.   ksExtraE     = #222;     kbExtraE     = $100 * Ord (ksExtraE);
  650.   ksExtraF     = #223;     kbExtraF     = $100 * Ord (ksExtraF);
  651.   ksExtraG     = #224;     kbExtraG     = $100 * Ord (ksExtraG);
  652.   ksExtraH     = #225;     kbExtraH     = $100 * Ord (ksExtraH);
  653.   ksExtraI     = #226;     kbExtraI     = $100 * Ord (ksExtraI);
  654.   ksExtraJ     = #227;     kbExtraJ     = $100 * Ord (ksExtraJ);
  655.   ksExtraK     = #228;     kbExtraK     = $100 * Ord (ksExtraK);
  656.   ksExtraL     = #229;     kbExtraL     = $100 * Ord (ksExtraL);
  657.   ksExtraM     = #230;     kbExtraM     = $100 * Ord (ksExtraM);
  658.   ksExtraN     = #231;     kbExtraN     = $100 * Ord (ksExtraN);
  659.   ksExtraO     = #232;     kbExtraO     = $100 * Ord (ksExtraO);
  660.   ksExtraP     = #233;     kbExtraP     = $100 * Ord (ksExtraP);
  661.   ksExtraQ     = #234;     kbExtraQ     = $100 * Ord (ksExtraQ);
  662.   ksExtraR     = #235;     kbExtraR     = $100 * Ord (ksExtraR);
  663.   ksExtraS     = #236;     kbExtraS     = $100 * Ord (ksExtraS);
  664.   ksExtraT     = #237;     kbExtraT     = $100 * Ord (ksExtraT);
  665.   ksExtraU     = #238;     kbExtraU     = $100 * Ord (ksExtraU);
  666.   ksExtraV     = #239;     kbExtraV     = $100 * Ord (ksExtraV);
  667.   ksExtraW     = #240;     kbExtraW     = $100 * Ord (ksExtraW);
  668.   ksExtraX     = #241;     kbExtraX     = $100 * Ord (ksExtraX);
  669.   ksExtraY     = #242;     kbExtraY     = $100 * Ord (ksExtraY);
  670.   ksExtraZ     = #243;     kbExtraZ     = $100 * Ord (ksExtraZ);
  671.   ksF1         = #59;      kbF1         = $100 * Ord (ksF1);
  672.   ksF2         = #60;      kbF2         = $100 * Ord (ksF2);
  673.   ksF3         = #61;      kbF3         = $100 * Ord (ksF3);
  674.   ksF4         = #62;      kbF4         = $100 * Ord (ksF4);
  675.   ksF5         = #63;      kbF5         = $100 * Ord (ksF5);
  676.   ksF6         = #64;      kbF6         = $100 * Ord (ksF6);
  677.   ksF7         = #65;      kbF7         = $100 * Ord (ksF7);
  678.   ksF8         = #66;      kbF8         = $100 * Ord (ksF8);
  679.   ksF9         = #67;      kbF9         = $100 * Ord (ksF9);
  680.   ksF10        = #68;      kbF10        = $100 * Ord (ksF10);
  681.   ksF11        = #133;     kbF11        = $100 * Ord (ksF11);
  682.   ksF12        = #134;     kbF12        = $100 * Ord (ksF12);
  683.   ksShF1       = #84;      kbShF1       = $100 * Ord (ksShF1);
  684.   ksShF2       = #85;      kbShF2       = $100 * Ord (ksShF2);
  685.   ksShF3       = #86;      kbShF3       = $100 * Ord (ksShF3);
  686.   ksShF4       = #87;      kbShF4       = $100 * Ord (ksShF4);
  687.   ksShF5       = #88;      kbShF5       = $100 * Ord (ksShF5);
  688.   ksShF6       = #89;      kbShF6       = $100 * Ord (ksShF6);
  689.   ksShF7       = #90;      kbShF7       = $100 * Ord (ksShF7);
  690.   ksShF8       = #91;      kbShF8       = $100 * Ord (ksShF8);
  691.   ksShF9       = #92;      kbShF9       = $100 * Ord (ksShF9);
  692.   ksShF10      = #93;      kbShF10      = $100 * Ord (ksShF10);
  693.   ksShF11      = #135;     kbShF11      = $100 * Ord (ksShF11);
  694.   ksShF12      = #136;     kbShF12      = $100 * Ord (ksShF12);
  695.   ksCtrlF1     = #94;      kbCtrlF1     = $100 * Ord (ksCtrlF1);
  696.   ksCtrlF2     = #95;      kbCtrlF2     = $100 * Ord (ksCtrlF2);
  697.   ksCtrlF3     = #96;      kbCtrlF3     = $100 * Ord (ksCtrlF3);
  698.   ksCtrlF4     = #97;      kbCtrlF4     = $100 * Ord (ksCtrlF4);
  699.   ksCtrlF5     = #98;      kbCtrlF5     = $100 * Ord (ksCtrlF5);
  700.   ksCtrlF6     = #99;      kbCtrlF6     = $100 * Ord (ksCtrlF6);
  701.   ksCtrlF7     = #100;     kbCtrlF7     = $100 * Ord (ksCtrlF7);
  702.   ksCtrlF8     = #101;     kbCtrlF8     = $100 * Ord (ksCtrlF8);
  703.   ksCtrlF9     = #102;     kbCtrlF9     = $100 * Ord (ksCtrlF9);
  704.   ksCtrlF10    = #103;     kbCtrlF10    = $100 * Ord (ksCtrlF10);
  705.   ksCtrlF11    = #137;     kbCtrlF11    = $100 * Ord (ksCtrlF11);
  706.   ksCtrlF12    = #138;     kbCtrlF12    = $100 * Ord (ksCtrlF12);
  707.   ksAltF1      = #104;     kbAltF1      = $100 * Ord (ksAltF1);
  708.   ksAltF2      = #105;     kbAltF2      = $100 * Ord (ksAltF2);
  709.   ksAltF3      = #106;     kbAltF3      = $100 * Ord (ksAltF3);
  710.   ksAltF4      = #107;     kbAltF4      = $100 * Ord (ksAltF4);
  711.   ksAltF5      = #108;     kbAltF5      = $100 * Ord (ksAltF5);
  712.   ksAltF6      = #109;     kbAltF6      = $100 * Ord (ksAltF6);
  713.   ksAltF7      = #110;     kbAltF7      = $100 * Ord (ksAltF7);
  714.   ksAltF8      = #111;     kbAltF8      = $100 * Ord (ksAltF8);
  715.   ksAltF9      = #112;     kbAltF9      = $100 * Ord (ksAltF9);
  716.   ksAltF10     = #113;     kbAltF10     = $100 * Ord (ksAltF10);
  717.   ksAltF11     = #139;     kbAltF11     = $100 * Ord (ksAltF11);
  718.   ksAltF12     = #140;     kbAltF12     = $100 * Ord (ksAltF12);
  719.   ksCancel     = #3;       kbCancel     = $100 * Ord (ksCancel);
  720.   ksCopy       = #4;       kbCopy       = $100 * Ord (ksCopy);
  721.   ksUndo       = #5;       kbUndo       = $100 * Ord (ksUndo);
  722.   ksRedo       = #6;       kbRedo       = $100 * Ord (ksRedo);
  723.   ksOpen       = #7;       kbOpen       = $100 * Ord (ksOpen);
  724.   ksClose      = #8;       kbClose      = $100 * Ord (ksClose);
  725.   ksCommand    = #9;       kbCommand    = $100 * Ord (ksCommand);
  726.   ksCreate     = #10;      kbCreate     = $100 * Ord (ksCreate);
  727.   ksExit       = #11;      kbExit       = $100 * Ord (ksExit);
  728.   ksFind       = #12;      kbFind       = $100 * Ord (ksFind);
  729.   ksHelp       = #13;      kbHelp       = $100 * Ord (ksHelp);
  730.   ksMark       = #28;      kbMark       = $100 * Ord (ksMark);
  731.   ksMessage    = #29;      kbMessage    = $100 * Ord (ksMessage);
  732.   ksMove       = #42;      kbMove       = $100 * Ord (ksMove);
  733.   ksNext       = #54;      kbNext       = $100 * Ord (ksNext);
  734.   ksPrevious   = #56;      kbPrevious   = $100 * Ord (ksPrevious);
  735.   ksOptions    = #57;      kbOptions    = $100 * Ord (ksOptions);
  736.   ksReference  = #58;      kbReference  = $100 * Ord (ksReference);
  737.   ksRefresh    = #69;      kbRefresh    = $100 * Ord (ksRefresh);
  738.   ksReplace    = #70;      kbReplace    = $100 * Ord (ksReplace);
  739.   ksResize     = #114;     kbResize     = $100 * Ord (ksResize);
  740.   ksRestart    = #142;     kbRestart    = $100 * Ord (ksRestart);
  741.   ksSuspend    = #144;     kbSuspend    = $100 * Ord (ksSuspend);
  742.   ksResume     = #149;     kbResume     = $100 * Ord (ksResume);
  743.   ksSave       = #150;     kbSave       = $100 * Ord (ksSave);
  744.   ksMenu       = #154;     kbMenu       = $100 * Ord (ksMenu);
  745.   ksClear      = #156;     kbClear      = $100 * Ord (ksClear);
  746.   ksSelect     = #158;     kbSelect     = $100 * Ord (ksSelect);
  747.   ksStop       = #164;     kbStop       = $100 * Ord (ksStop);
  748.  
  749.   ksInt               = #250; kbInt               = $100 * Ord (ksInt);
  750.   ksTerm              = #251; kbTerm              = $100 * Ord (ksTerm);
  751.   ksHUp               = #252; kbHUp               = $100 * Ord (ksHUp);
  752.   ksScreenSizeChanged = #254; kbScreenSizeChanged = $100 * Ord (ksScreenSizeChanged);
  753.  
  754.   chBell       = #7;       kbBell       = Ord (chBell);
  755.   chBkSp       = #8;       kbBkSp       = Ord (chBkSp);
  756.   chTab        = #9;       kbTab        = Ord (chTab);
  757.   chLF         = #10;      kbLF         = Ord (chLF);
  758.   chFF         = #12;      kbFF         = Ord (chFF);
  759.   chCR         = #13;      kbCR         = Ord (chCR);
  760.   chEnter      = chCR;     kbEnter      = Ord (chEnter);
  761.   chEsc        = #27;      kbEsc        = Ord (chEsc);
  762.   chNBSp       = #160;     kbNBSp       = Ord (chNBSp);
  763.  
  764.   chCtrlA      = #1;       kbCtrlA      = Ord (chCtrlA);
  765.   chCtrlB      = #2;       kbCtrlB      = Ord (chCtrlB);
  766.   chCtrlC      = #3;       kbCtrlC      = Ord (chCtrlC);
  767.   chCtrlD      = #4;       kbCtrlD      = Ord (chCtrlD);
  768.   chCtrlE      = #5;       kbCtrlE      = Ord (chCtrlE);
  769.   chCtrlF      = #6;       kbCtrlF      = Ord (chCtrlF);
  770.   chCtrlG      = #7;       kbCtrlG      = Ord (chCtrlG);
  771.   chCtrlH      = #8;       kbCtrlH      = Ord (chCtrlH);
  772.   chCtrlI      = #9;       kbCtrlI      = Ord (chCtrlI);
  773.   chCtrlJ      = #10;      kbCtrlJ      = Ord (chCtrlJ);
  774.   chCtrlK      = #11;      kbCtrlK      = Ord (chCtrlK);
  775.   chCtrlL      = #12;      kbCtrlL      = Ord (chCtrlL);
  776.   chCtrlM      = #13;      kbCtrlM      = Ord (chCtrlM);
  777.   chCtrlN      = #14;      kbCtrlN      = Ord (chCtrlN);
  778.   chCtrlO      = #15;      kbCtrlO      = Ord (chCtrlO);
  779.   chCtrlP      = #16;      kbCtrlP      = Ord (chCtrlP);
  780.   chCtrlQ      = #17;      kbCtrlQ      = Ord (chCtrlQ);
  781.   chCtrlR      = #18;      kbCtrlR      = Ord (chCtrlR);
  782.   chCtrlS      = #19;      kbCtrlS      = Ord (chCtrlS);
  783.   chCtrlT      = #20;      kbCtrlT      = Ord (chCtrlT);
  784.   chCtrlU      = #21;      kbCtrlU      = Ord (chCtrlU);
  785.   chCtrlV      = #22;      kbCtrlV      = Ord (chCtrlV);
  786.   chCtrlW      = #23;      kbCtrlW      = Ord (chCtrlW);
  787.   chCtrlX      = #24;      kbCtrlX      = Ord (chCtrlX);
  788.   chCtrlY      = #25;      kbCtrlY      = Ord (chCtrlY);
  789.   chCtrlZ      = #26;      kbCtrlZ      = Ord (chCtrlZ);
  790.  
  791.   chLineHS     = #196;
  792.   chLineVS     = #179;
  793.   chLineHD     = #205;
  794.   chLineVD     = #186;
  795.   chLineHSS    = chLineHS;
  796.   chLineVSS    = chLineVS;
  797.   chLineHDS    = chLineHD;
  798.   chLineVDS    = chLineVS;
  799.   chLineHSD    = chLineHS;
  800.   chLineVSD    = chLineVD;
  801.   chLineHDD    = chLineHD;
  802.   chLineVDD    = chLineVD;
  803.   chCornerTLS  = #218;
  804.   chCornerTRS  = #191;
  805.   chCornerBLS  = #192;
  806.   chCornerBRS  = #217;
  807.   chCornerTLD  = #201;
  808.   chCornerTRD  = #187;
  809.   chCornerBLD  = #200;
  810.   chCornerBRD  = #188;
  811.   chCornerTLSS = chCornerTLS;
  812.   chCornerTRSS = chCornerTRS;
  813.   chCornerBLSS = chCornerBLS;
  814.   chCornerBRSS = chCornerBRS;
  815.   chCornerTLDS = #213;
  816.   chCornerTRDS = #184;
  817.   chCornerBLDS = #212;
  818.   chCornerBRDS = #190;
  819.   chCornerTLSD = #214;
  820.   chCornerTRSD = #183;
  821.   chCornerBLSD = #211;
  822.   chCornerBRSD = #189;
  823.   chCornerTLDD = chCornerTLD;
  824.   chCornerTRDD = chCornerTRD;
  825.   chCornerBLDD = chCornerBLD;
  826.   chCornerBRDD = chCornerBRD;
  827.   chTeeTS      = #194;
  828.   chTeeBS      = #193;
  829.   chTeeLS      = #195;
  830.   chTeeRS      = #180;
  831.   chTeeTD      = #203;
  832.   chTeeBD      = #202;
  833.   chTeeLD      = #204;
  834.   chTeeRD      = #185;
  835.   chTeeTSS     = chTeeTS;
  836.   chTeeBSS     = chTeeBS;
  837.   chTeeLSS     = chTeeLS;
  838.   chTeeRSS     = chTeeRS;
  839.   chTeeTDS     = #209;
  840.   chTeeBDS     = #207;
  841.   chTeeLDS     = #198;
  842.   chTeeRDS     = #181;
  843.   chTeeTSD     = #210;
  844.   chTeeBSD     = #208;
  845.   chTeeLSD     = #199;
  846.   chTeeRSD     = #182;
  847.   chTeeTDD     = chTeeTD;
  848.   chTeeBDD     = chTeeBD;
  849.   chTeeLDD     = chTeeLD;
  850.   chTeeRDD     = chTeeRD;
  851.   chCenterS    = #197;
  852.   chCenterD    = #206;
  853.   chCenterSS   = chCenterS;
  854.   chCenterDS   = #216;
  855.   chCenterSD   = #215;
  856.   chCenterDD   = chCenterD;
  857.  
  858.   chArrowU     = #24;
  859.   chArrowD     = #25;
  860.   chArrowL     = #27;
  861.   chArrowR     = #26;
  862.   chArrowUD    = #18;
  863.   chArrowLR    = #29;
  864.   chTriangleU  = #30;
  865.   chTriangleD  = #31;
  866.   chTriangleL  = #17;
  867.   chTriangleR  = #16;
  868.   chBlock      = #219;
  869.   chBlockT     = #223;
  870.   chBlockB     = #220;
  871.   chBlockL     = #221;
  872.   chBlockR     = #222;
  873.  
  874.   chClubs      = #5;
  875.   chSpades     = #6;
  876.   chHearts     = #3;
  877.   chDiamonds   = #4;
  878.   chChkBoard1  = #176;
  879.   chChkBoard2  = #177;
  880.   chChkBoard3  = #178;
  881.   chDegree     = #248;
  882.   chPlusMinus  = #241;
  883.   chBullet     = #254;
  884.   chLEqual     = #243;
  885.   chGEqual     = #242;
  886.   chPi         = #227;
  887.   chSmilie1    = #1;
  888.   chSmilie2    = #2;
  889.   chParagraph  = #21;
  890.  
  891.   shLeftShift  = 1;
  892.   shRightShift = 2;
  893.   shShift      = (shRightShift + shLeftShift);
  894.   shLeftCtrl   = 4;
  895.   shRightCtrl  = 8;
  896.   shCtrl       = (shRightCtrl + shLeftCtrl);
  897.   shLeftAlt    = 16;
  898.   shAlt        = shLeftAlt;
  899.   shRightAlt   = 32;
  900.   shAltGr      = shRightAlt;
  901.   shAnyAlt     = (shLeftAlt + shRightAlt);
  902.   shExtra      = 64;
  903.  
  904. const
  905.   XCRT       : Boolean = False;
  906.   VisualBell : Boolean = False; { If set, Beep does a Flash instead }
  907.  
  908. type
  909.   TKey = Word;
  910.  
  911.   TCursorShape = (CursorIgnored, CursorHidden, CursorNormal, CursorFat, CursorBlock);
  912.  
  913.   TCRTUpdate = (UpdateNever, UpdateWaitInput, UpdateInput,
  914.                 UpdateRegularly, UpdateAlways);
  915.  
  916.   TPoint = record
  917.     X, Y : Integer
  918.   end;
  919.  
  920.   TWindowXY = record
  921.     X, Y : Byte
  922.   end;
  923.  
  924.   PCharAttr = ^TCharAttr;
  925.   TCharAttr = record
  926.     Ch        : Char;
  927.     Attr      : TTextAttr;
  928.     PCCharSet : Boolean
  929.   end;
  930.  
  931.   PCharAttrs = ^TCharAttrs;
  932.   TCharAttrs = array [1 .. MaxVarSize div SizeOf (TCharAttr)] of TCharAttr;
  933.  
  934. var
  935.   { WindMin, WindMax, WindowMin and WindowMax are OBSOLETE! Use Window
  936.     and GetWindow instead. }
  937.   WindowMin : TWindowXY absolute WindMin;
  938.   WindowMax : TWindowXY absolute WindMax;
  939.  
  940.   ScreenSize : TPoint; { Contains the size of the screen }
  941.  
  942.   IsMonochrome : Boolean;
  943.  
  944. const
  945.   VirtualShiftState : Integer = 0;
  946.  
  947. { Tell which modifier keys are currently pressed (or 0 on systems where
  948.   this is not supported). }
  949. function  GetShiftState : Integer;
  950.  
  951. { Get the extent of the current window. Use this procedure rather than
  952.   reading WindMin and WindMax or WindowMin and WindowMax, since this
  953.   routine allows for window sizes larger than 255. }
  954. procedure GetWindow (var x1, y1, x2, y2 : Integer);
  955.  
  956. { Dummies }
  957. procedure SetCRTUpdate (Update : TCRTUpdate);
  958. procedure CRTUpdate;
  959.  
  960. { Returns Ord (key) for normal keys and $100 * Ord (fkey) for function keys }
  961. function  ReadKeyWord : TKey;
  962.  
  963. { Extract the character and scan code from a TKey value }
  964. function  Key2Char (k : TKey) : Char;
  965. function  Key2Scan (k : TKey) : Char;
  966.  
  967. { Convert a key to upper/lower case if it is a letter, leave it unchanged
  968.   otherwise }
  969. function  UpCaseKey (k : TKey) : TKey;
  970. function  LoCaseKey (k : TKey) : TKey;
  971.  
  972. { Produce a beep or a screen flash }
  973. procedure Beep;
  974. procedure Flash;
  975.  
  976. { Get size of current window (calculated using GetWindow) }
  977. function  GetXMax : Integer;
  978. function  GetYMax : Integer;
  979.  
  980. { Get/goto an absolute position }
  981. function  WhereXAbs : Integer;
  982. function  WhereYAbs : Integer;
  983. procedure GotoXYAbs (X, Y : Integer);
  984.  
  985. procedure SetCursorShape (Shape : TCursorShape);
  986. function  GetCursorShape : TCursorShape;
  987.  
  988. procedure HideCursor;
  989. procedure HiddenCursor;
  990. procedure NormalCursor;
  991. procedure FatCursor;
  992. procedure BlockCursor;
  993. procedure IgnoreCursor;
  994.  
  995. function  GetTextColor : Integer;
  996. function  GetTextBackground : Integer;
  997.  
  998. { Write string at given position without moving the cursor. Truncated at
  999.   right margin. }
  1000. procedure WriteStrAt (x, y : Integer; s : String; Attr : TTextAttr);
  1001.  
  1002. { Write (several copies of) a char at given position without moving the
  1003.   cursor. Truncated at right margin. }
  1004. procedure WriteCharAt (x, y, Count : Integer; Ch : Char; Attr : TTextAttr);
  1005.  
  1006. { Write characters with specified attributes at the given position without
  1007.   moving the cursor. Truncated at right margin. }
  1008. procedure WriteCharAttrAt (x, y, Count : Integer; CharAttr : PCharAttrs);
  1009.  
  1010. { Write a char while moving the cursor }
  1011. procedure WriteChar (Ch : Char);
  1012.  
  1013. { Read a character from a screen posistion }
  1014. procedure ReadChar (x, y : Integer; var Ch : Char; var Attr : TTextAttr);
  1015.  
  1016. { Change only text attribute, leave character }
  1017. procedure ChangeTextAttr (x, y, Count : Integer; NewAttr : TTextAttr);
  1018.  
  1019. { Fill current window }
  1020. procedure FillWin (Ch : Char; Attr : TTextAttr);
  1021.  
  1022. { Calculate size of memory required for ReadWin in current window. }
  1023. function  WinSize : SizeType;
  1024.  
  1025. { Save window contents. Buf must be WinSize bytes large. }
  1026. procedure ReadWin (var Buf);
  1027.  
  1028. { Restore window contents saved by ReadWin. The size of the current
  1029.   window must match the size of the window from which ReadWin was
  1030.   used, but the position may be different. }
  1031. procedure WriteWin (const Buf);
  1032.  
  1033. type
  1034.   WinState = record
  1035.     x1, y1, x2, y2, WhereX, WhereY, NewX1, NewY1, NewX2, NewY2 : Integer;
  1036.     TextAttr : TTextAttr;
  1037.     CursorShape : TCursorShape;
  1038.     TextMode : Integer;
  1039.     BufSize : SizeType;
  1040.     Buffer : ^Byte
  1041.   end;
  1042.  
  1043. { Save window position and size, cursor position, text attribute and
  1044.   cursor shape -- *not* the window contents. }
  1045. procedure SaveWin (var State : WinState);
  1046.  
  1047. { Make a new window (like Window), and save the contents of the
  1048.   screen below the window as well as the position and size, cursor
  1049.   position, text attribute and cursor shape of the old window. }
  1050. procedure MakeWin (var State : WinState; x1, y1, x2, y2 : Integer);
  1051.  
  1052. { Create window in full size, save previous text mode and all values
  1053.   that MakeWin does. }
  1054. procedure SaveScreen (var State : WinState);
  1055.  
  1056. { Restore the data saved by SaveWin, MakeWin or SaveScreen. }
  1057. procedure RestoreWin (var State : WinState);
  1058.  
  1059. { TPCRT compatibility }
  1060.  
  1061. { Write a string at the given position without moving the cursor.
  1062.   Truncated at the right margin. }
  1063. procedure WriteString (const s : String; y, x : Integer);
  1064.  
  1065. { Write a string at the given position with the given attribute
  1066.   without moving the cursor. Truncated at the right margin. }
  1067. procedure FastWriteWindow (const s : String; y, x : Integer; Attr : TTextAttr);
  1068.  
  1069. { Write a string at the given absolute position with the given
  1070.   attribute without moving the cursor. Truncated at the right
  1071.   margin. }
  1072. procedure FastWrite       (const s : String; y, x : Integer; Attr : TTextAttr);
  1073.  
  1074. {
  1075.   Trapping runtime errors, see the Trap unit. Besides the notes in
  1076.   that unit, additionally note for this BP version:
  1077.   - Trap has been tested with BP version 7.0 only and mainly in real
  1078.     mode, but it may work with TP 6.0 or in protected mode, too.
  1079.   - You should not install any ExitProc's after calling TrapExec.
  1080.   - Real mode only: You must not call TrapExec from an overlayed
  1081.     unit.
  1082.   - protected mode only: You should call TrapExec from a code
  1083.     segment with the following attributes: FIXED PRELOAD PERMANENT.
  1084.     (Though I'm not sure if this is really necessary.)
  1085. }
  1086. const
  1087.   TrappedExitCode  : Integer = 0;
  1088.   TrappedErrorAddr : Pointer = nil;
  1089.  
  1090. type
  1091.   TTrapProc = procedure (Trapped : Boolean);
  1092.  
  1093. procedure TrapExec (p : TTrapProc);
  1094.  
  1095. implementation
  1096.  
  1097. const
  1098.   StartCPUTimeSeconds      : LongInt = 0;
  1099.   StartCPUTimeMicroSeconds : LongInt = 0;
  1100.   MonthOffset : array [1 .. 12] of Integer = (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334);
  1101.  
  1102. var
  1103.   ExitSave : Pointer;
  1104.  
  1105. { System extensions }
  1106.  
  1107. function Min (a, b : Integer) : Integer;
  1108. begin
  1109.   if a < b then Min := a else Min := b
  1110. end;
  1111.  
  1112. function Max (a, b : Integer) : Integer;
  1113. begin
  1114.   if a > b then Max := a else Max := b
  1115. end;
  1116.  
  1117. function InPortB (PortNumber : Word) : Byte;
  1118. begin
  1119.   InPortB := Port [PortNumber]
  1120. end;
  1121.  
  1122. function InPortW (PortNumber : Word) : Word;
  1123. begin
  1124.   InPortW := PortW [PortNumber]
  1125. end;
  1126.  
  1127. procedure OutPortB (PortNumber : Word; Val : Byte);
  1128. begin
  1129.   Port [PortNumber] := Val
  1130. end;
  1131.  
  1132. procedure OutPortW (PortNumber, Val : Word);
  1133. begin
  1134.   PortW [PortNumber] := Val
  1135. end;
  1136.  
  1137. function IOPerm (From, Num : MedCard; On : Integer) : Integer;
  1138. begin
  1139.   IOPerm := 0
  1140. end;
  1141.  
  1142. function IOPL (Level : Integer) : Integer;
  1143. begin
  1144.   IOPL := 0
  1145. end;
  1146.  
  1147. function SetEUID (EUID : Integer) : Integer;
  1148. begin
  1149.   SetEUID := 0
  1150. end;
  1151.  
  1152. function UserID  (Effective : Boolean) : Integer;
  1153. begin
  1154.   UserID := 0
  1155. end;
  1156.  
  1157. function GroupID (Effective : Boolean) : Integer;
  1158. begin
  1159.   GroupID := 0
  1160. end;
  1161.  
  1162. function CGetMem (Size : SizeType) : Pointer;
  1163. var p, HeapErrorSave : Pointer;
  1164. begin
  1165.   HeapErrorSave := HeapError;
  1166.   HeapError := @HeapErrorNilReturn;
  1167.   GetMem (p, Size);
  1168.   HeapError := HeapErrorSave;
  1169.   CGetMem := p
  1170. end;
  1171.  
  1172. function HeapErrorNilReturn (Size : Word) : Integer;
  1173. begin
  1174.   HeapErrorNilReturn := HeapErrorNil
  1175. end;
  1176.  
  1177. function MemComp (const s1, s2; Size : SizeType) : Integer; assembler;
  1178. asm
  1179.    mov  dx, ds
  1180.    lds  si, s1
  1181.    les  di, s2
  1182.    cld
  1183.    mov  ax, Size
  1184.    mov  cx, ax
  1185.    shr  cx, 1
  1186.    jcxz @1
  1187.    repe cmpsw
  1188.    jne  @2
  1189. @1:shr  ax, 1
  1190.    jnc  @3
  1191.    cmpsb
  1192. @2:mov  ax, 1
  1193.    ja   @4
  1194.    mov  ax, -1
  1195.    jb   @4
  1196. @3:mov  ax, 0
  1197. @4:mov  ds, dx
  1198. end;
  1199.  
  1200. procedure ReverseBytes (var Buf; ElementSize, Count : SizeType);
  1201. var
  1202.   i, j, o1, o2 : SizeType;
  1203.   b : Byte;
  1204.   ByteBuf : array [1 .. { ElementSize * Count -- BP can't handle this } MaxVarSize div SizeOf (Byte)] of Byte absolute Buf;
  1205. begin
  1206.   for i := 0 to Count - 1 do
  1207.     for j := 1 to ElementSize div 2 do
  1208.       begin
  1209.         o1 := i * ElementSize + j;
  1210.         o2 := i * ElementSize + ElementSize + 1 - j;
  1211.         b := ByteBuf [o1];
  1212.         ByteBuf [o1] := ByteBuf [o2];
  1213.         ByteBuf [o2] := b
  1214.       end
  1215. end;
  1216.  
  1217. procedure ConvertFromLittleEndian (var Buf; ElementSize, Count : SizeType);
  1218. begin
  1219.   if BytesBigEndian then ReverseBytes (Buf, ElementSize, Count)
  1220. end;
  1221.  
  1222. procedure ConvertFromBigEndian (var Buf; ElementSize, Count : SizeType);
  1223. begin
  1224.   if not BytesBigEndian then ReverseBytes (Buf, ElementSize, Count)
  1225. end;
  1226.  
  1227. procedure ConvertToLittleEndian (var Buf; ElementSize, Count : SizeType);
  1228. begin
  1229.   if BytesBigEndian then ReverseBytes (Buf, ElementSize, Count)
  1230. end;
  1231.  
  1232. procedure ConvertToBigEndian (var Buf; ElementSize, Count : SizeType);
  1233. begin
  1234.   if not BytesBigEndian then ReverseBytes (Buf, ElementSize, Count)
  1235. end;
  1236.  
  1237. type
  1238.   TByteArray = array [0 .. MaxVarSize div SizeOf (Byte)] of Byte;
  1239.   PByteArray = ^TByteArray;
  1240.  
  1241. procedure BlockReadLittleEndian (var aFile : File; var Buf; ElementSize, Count : SizeType);
  1242. begin
  1243.   BlockRead (aFile, Buf, ElementSize * Count);
  1244.   if InOutRes = 0 then
  1245.     ConvertFromLittleEndian (Buf, ElementSize, Count)
  1246. end;
  1247.  
  1248. procedure BlockReadBigEndian (var aFile : File; var Buf; ElementSize, Count : SizeType);
  1249. begin
  1250.   BlockRead (aFile, Buf, ElementSize * Count);
  1251.   if InOutRes = 0 then
  1252.     ConvertFromBigEndian (Buf, ElementSize, Count)
  1253. end;
  1254.  
  1255. procedure BlockWriteLittleEndian (var aFile : File; const Buf; ElementSize, Count : SizeType);
  1256. var p : Pointer;
  1257. begin
  1258.   GetMem (p, ElementSize * Count);
  1259.   Move (Buf, p^, ElementSize * Count);
  1260.   ConvertToLittleEndian (p^, ElementSize, Count);
  1261.   BlockWrite (aFile, p^, ElementSize * Count);
  1262.   FreeMem (p, ElementSize * Count)
  1263. end;
  1264.  
  1265. procedure BlockWriteBigEndian (var aFile : File; const Buf; ElementSize, Count : SizeType);
  1266. var p : Pointer;
  1267. begin
  1268.   GetMem (p, ElementSize * Count);
  1269.   Move (Buf, p^, ElementSize * Count);
  1270.   ConvertToBigEndian (p^, ElementSize, Count);
  1271.   BlockWrite (aFile, p^, ElementSize * Count);
  1272.   FreeMem (p, ElementSize * Count)
  1273. end;
  1274.  
  1275. {$P+}
  1276. procedure ReadStringLittleEndian (var f : File; var s : String);
  1277. var StringLength, Temp : LongInt;
  1278. begin
  1279.   BlockRead (f, StringLength, SizeOf (StringLength));
  1280.   { Ignore the high bytes, BP can't handle them }
  1281.   BlockRead (f, Temp, SizeOf (Temp));
  1282.   if InOutRes = 0 then
  1283.     begin
  1284.       ConvertFromLittleEndian (StringLength, SizeOf (StringLength), 1);
  1285.       { Ignore characters exceeding 255, BP can't handle them }
  1286.       Temp := StringLength;
  1287.       if Temp > $ff then Temp := $ff;
  1288.       SetLength (s, Temp);
  1289.       BlockRead (f, s [1], Temp);
  1290.       Seek (f, FilePos (f) + StringLength - Temp)
  1291.     end
  1292. end;
  1293.  
  1294. procedure ReadStringBigEndian (var f : File; var s : String);
  1295. var StringLength, Temp : LongInt;
  1296. begin
  1297.   { Ignore the high bytes, BP can't handle them }
  1298.   BlockRead (f, Temp, SizeOf (Temp));
  1299.   BlockRead (f, StringLength, SizeOf (StringLength));
  1300.   if InOutRes = 0 then
  1301.     begin
  1302.       ConvertFromBigEndian (StringLength, SizeOf (StringLength), 1);
  1303.       { Ignore characters exceeding 255, BP can't handle them }
  1304.       Temp := StringLength;
  1305.       if Temp > $ff then Temp := $ff;
  1306.       SetLength (s, Temp);
  1307.       BlockRead (f, s [1], Temp);
  1308.       Seek (f, FilePos (f) + StringLength - Temp)
  1309.     end
  1310. end;
  1311.  
  1312. procedure WriteStringLittleEndian (var f : File; const s : String);
  1313. var StringLength : LongInt;
  1314. begin
  1315.   StringLength := Length (s);
  1316.   ConvertToLittleEndian (StringLength, SizeOf (StringLength), 1);
  1317.   BlockWrite (f, StringLength, SizeOf (StringLength));
  1318.   StringLength := 0;
  1319.   BlockWrite (f, StringLength, SizeOf (StringLength));
  1320.   BlockWrite (f, PChar (@s [1])^ { BP requires this nonsense }, Length (s))
  1321. end;
  1322.  
  1323. procedure WriteStringBigEndian (var f : File; const s : String);
  1324. var StringLength : LongInt;
  1325. begin
  1326.   StringLength := 0;
  1327.   BlockWrite (f, StringLength, SizeOf (StringLength));
  1328.   StringLength := Length (s);
  1329.   ConvertToBigEndian (StringLength, SizeOf (StringLength), 1);
  1330.   BlockWrite (f, StringLength, SizeOf (StringLength));
  1331.   BlockWrite (f, PChar (@s [1])^ { BP requires this nonsense }, Length (s))
  1332. end;
  1333. {$P-}
  1334.  
  1335. function NewString (const s : String) : PString;
  1336. var p : PString;
  1337. begin
  1338.   GetMem (p, Length (s) + 1);
  1339.   p^ := s;
  1340.   NewString := p
  1341. end;
  1342.  
  1343. procedure DisposeString (p : PString);
  1344. begin
  1345.   if p <> nil then FreeMem (p, Length (p^) + 1)
  1346. end;
  1347.  
  1348. const
  1349.   UpCaseSet = ['A' .. 'Z', 'Ä', 'Ö', 'Ü', 'A', 'E', 'I', 'O', 'U', 'Å', 'Æ', 'Ç', 'É', 'Ñ'];
  1350.   LoCaseSet = ['a' .. 'z', 'ä', 'ö', 'ü', 'â', 'à', 'á', 'ê', 'ë', 'è', 'ï', 'î',
  1351.                'ì', 'í', 'ô', 'ò', 'ó', 'û', 'ù', 'ú', 'å', 'æ', 'ç', 'é', 'ñ'];
  1352.  
  1353. function IsUpCase (ch : Char) : Boolean;
  1354. begin
  1355.   IsUpCase := ch in UpCaseSet
  1356. end;
  1357.  
  1358. function IsLoCase (ch : Char) : Boolean;
  1359. begin
  1360.   IsLoCase := ch in LoCaseSet
  1361. end;
  1362.  
  1363. function IsAlphaNum (ch : Char) : Boolean;
  1364. begin
  1365.   IsAlphaNum := ch in (UpCaseSet + LoCaseSet + ['0' .. '9'])
  1366. end;
  1367.  
  1368. function IsAlphaNumUnderscore (ch : Char) : Boolean;
  1369. begin
  1370.   IsAlphaNumUnderscore := ch in (UpCaseSet + LoCaseSet + ['0' .. '9', '_'])
  1371. end;
  1372.  
  1373. function IsPrintable (ch : Char) : Boolean;
  1374. begin
  1375.   IsPrintable := ch >= ' '
  1376. end;
  1377.  
  1378. function UpCase (Ch : Char) : Char;
  1379. begin
  1380.   case Ch of
  1381.     #0 .. Pred ('a') :   UpCase := Ch;
  1382.     'a' .. 'z' :         UpCase := Chr (Ord (Ch) - Ord ('a') + Ord ('A'));
  1383.     'ä' :                UpCase := 'Ä';
  1384.     'ö' :                UpCase := 'Ö';
  1385.     'ü' :                UpCase := 'Ü';
  1386.     'â', 'à', 'á' :      UpCase := 'A';
  1387.     'ê', 'ë', 'è' :      UpCase := 'E';
  1388.     'ï', 'î', 'ì', 'í' : UpCase := 'I';
  1389.     'ô', 'ò', 'ó' :      UpCase := 'O';
  1390.     'û', 'ù', 'ú' :      UpCase := 'U';
  1391.     'å' :                UpCase := 'Å';
  1392.     'æ' :                UpCase := 'Æ';
  1393.     'ç' :                UpCase := 'Ç';
  1394.     'é' :                UpCase := 'É';
  1395.     'ñ' :                UpCase := 'Ñ';
  1396.     else                 UpCase := Ch
  1397.   end
  1398. end;
  1399.  
  1400. function LoCase (Ch : Char) : Char;
  1401. begin
  1402.   case Ch of
  1403.     #0 .. Pred ('A') :   LoCase := Ch;
  1404.     'A' .. 'Z' :         LoCase := Chr (Ord (Ch) - Ord ('A') + Ord ('a'));
  1405.     'Ä' :                LoCase := 'ä';
  1406.     'Ö' :                LoCase := 'ö';
  1407.     'Ü' :                LoCase := 'ü';
  1408.     'Å' :                LoCase := 'å';
  1409.     'Æ' :                LoCase := 'æ';
  1410.     'Ç' :                LoCase := 'ç';
  1411.     'É' :                LoCase := 'é';
  1412.     'Ñ' :                LoCase := 'ñ';
  1413.     else                 LoCase := Ch
  1414.   end
  1415. end;
  1416.  
  1417. function UpCaseStr (s : String) : String;
  1418. begin
  1419.   UpCaseString (s);
  1420.   UpCaseStr := s
  1421. end;
  1422.  
  1423. function LoCaseStr (s : String) : String;
  1424. begin
  1425.   LoCaseString (s);
  1426.   LoCaseStr := s
  1427. end;
  1428.  
  1429. {$P+}
  1430. procedure UpCaseString (var s : String);
  1431. var z : Integer;
  1432. begin
  1433.   for z := 1 to Length (s) do s [z] := UpCase (s [z])
  1434. end;
  1435.  
  1436. procedure LoCaseString (var s : String);
  1437. var z : Integer;
  1438. begin
  1439.   for z := 1 to Length (s) do s [z] := LoCase (s [z])
  1440. end;
  1441.  
  1442. procedure SetLength (var s : String; NewLength : Integer);
  1443. begin
  1444.   s [0] := Chr (Min (GetStringCapacity (s), Max (0, NewLength)))
  1445. end;
  1446.  
  1447. function StringOfChar (Ch : Char; Count : Integer) : TString;
  1448. var
  1449.   s : TString;
  1450.   i : Integer;
  1451. begin
  1452.   SetLength (s, Min (GetStringCapacity (s), Max (0, Count)));
  1453.   for i := 1 to Length (s) do s [i] := Ch;
  1454.   StringOfChar := s
  1455. end;
  1456.  
  1457. procedure TrimLeft (var s : String);
  1458. var i : Integer;
  1459. begin
  1460.   i := 1;
  1461.   while (i <= Length (s)) and (s [i] in SpaceCharacters) do Inc (i);
  1462.   Delete (s, 1, i - 1)
  1463. end;
  1464.  
  1465. procedure TrimRight (var s : String);
  1466. var i : Integer;
  1467. begin
  1468.   i := Length (s);
  1469.   while (i > 0) and (s [i] in SpaceCharacters) do Dec (i);
  1470.   Delete (s, i + 1, Length(s) - i)
  1471. end;
  1472.  
  1473. procedure TrimBoth (var s : String);
  1474. begin
  1475.   TrimLeft (s);
  1476.   TrimRight (s)
  1477. end;
  1478.  
  1479. function TrimLeftStr (s : String) :TString;
  1480. begin
  1481.   TrimLeft (s);
  1482.   TrimLeftStr := s
  1483. end;
  1484.  
  1485. function TrimRightStr (s : String) : TString;
  1486. begin
  1487.   TrimRight (s);
  1488.   TrimRightStr := s
  1489. end;
  1490.  
  1491. function TrimBothStr (s : String) : TString;
  1492. begin
  1493.   TrimBoth (s);
  1494.   TrimBothStr := s
  1495. end;
  1496.  
  1497. function GetStringCapacity (var s : String) : Integer;
  1498. begin
  1499.   GetStringCapacity := High (s)
  1500. end;
  1501. {$P-}
  1502.  
  1503. function LastPos (const SubStr, Str : String) : Integer;
  1504. begin
  1505.   LastPos := LastPosTill (SubStr, Str, Length (Str))
  1506. end;
  1507.  
  1508. function CharPos (const Chars : CharSet; const Str : String) : Integer;
  1509. var i : Integer;
  1510. begin
  1511.   i := 1;
  1512.   while (i <= Length (Str)) and not (Str [i] in Chars) do Inc (i);
  1513.   if i > Length (Str) then CharPos := 0 else CharPos := i
  1514. end;
  1515.  
  1516. function LastCharPos (const Chars : CharSet; const Str : String) : Integer;
  1517. var i : Integer;
  1518. begin
  1519.   i := Length (Str);
  1520.   while (i > 0) and not (Str [i] in Chars) do Dec (i);
  1521.   LastCharPos := i
  1522. end;
  1523.  
  1524. function PosFrom (const SubStr, Str : String; From : Integer) : Integer;
  1525. var m, i, n : Integer;
  1526. begin
  1527.   m := Max (1, From);
  1528.   case Length (SubStr) of
  1529.     0: PosFrom := From;
  1530.     1: begin
  1531.          i := m;
  1532.          while (i <= Length (Str)) and (Str [i] <> SubStr [1]) do Inc (i);
  1533.          if i > Length (Str) then PosFrom := 0 else PosFrom := i
  1534.        end;
  1535.     else
  1536.       n := Length (Str) - Length (SubStr) + 1;
  1537.       i := m;
  1538.       while (i <= n) and (MemComp (Str [i], SubStr [1], Length (SubStr)) <> 0) do Inc (i);
  1539.       if i > n then PosFrom := 0 else PosFrom := i
  1540.   end
  1541. end;
  1542.  
  1543. function LastPosTill (const SubStr, Str : String; Till : Integer) : Integer;
  1544. var m, i : Integer;
  1545. begin
  1546.   m := Max (0, Min (Length (Str), Till));
  1547.   case Length (SubStr) of
  1548.     0: LastPosTill := m + 1;
  1549.     1: begin
  1550.          i := m;
  1551.          while (i > 0) and (Str [i] <> SubStr [1]) do Dec (i);
  1552.          LastPosTill := i
  1553.        end;
  1554.     else
  1555.       i := m - Length (SubStr) + 1;
  1556.       while (i > 0) and (MemComp (Str [i], SubStr [1], Length (SubStr)) <> 0) do Dec (i);
  1557.       if i < 0 then LastPosTill := 0 else LastPosTill := i
  1558.   end
  1559. end;
  1560.  
  1561. function CharPosFrom (const Chars : CharSet; const Str : String; From : Integer) : Integer;
  1562. var i : Integer;
  1563. begin
  1564.   i := Max (1, From);
  1565.   while (i <= Length (Str)) and not (Str [i] in Chars) do Inc (i);
  1566.   if i > Length (Str) then CharPosFrom := 0 else CharPosFrom := i
  1567. end;
  1568.  
  1569. function LastCharPosTill (const Chars : CharSet; const Str : String; Till : Integer) : Integer;
  1570. var i : Integer;
  1571. begin
  1572.   i := Max (0, Min (Length (Str), Till));
  1573.   while (i > 0) and not (Str [i] in Chars) do Dec (i);
  1574.   LastCharPosTill := i
  1575. end;
  1576.  
  1577. function IsPrefix (const Prefix, s : String) : Boolean;
  1578. begin
  1579.   IsPrefix := (Length (s) >= Length (Prefix)) and (Copy (s, 1, Length (Prefix)) = Prefix)
  1580. end;
  1581.  
  1582. function IsSuffix (const Suffix, s : String) : Boolean;
  1583. begin
  1584.   IsSuffix := (Length (s) >= Length (Suffix)) and (Copy (s, Length (s) - Length (Suffix) + 1, Length (Suffix)) = Suffix)
  1585. end;
  1586.  
  1587. function NewCString (const Source : String) : CString;
  1588. var Dest : CString;
  1589. begin
  1590.   GetMem (Dest, Length (Source) + 1);
  1591.   Move (Source [1], Dest [0], Length (Source));
  1592.   Dest [Length (Source)] := #0;
  1593.   NewCString := Dest
  1594. end;
  1595.  
  1596. function Integer2String (i : Integer) : TString;
  1597. var s : TString;
  1598. begin
  1599.   Str (i, s);
  1600.   Integer2String := s
  1601. end;
  1602.  
  1603. procedure GetBinding (var f : Text; var aBinding : BindingType);
  1604. var
  1605.   Attr : TDosAttr;
  1606.   dt : DateTime;
  1607.   p, y2 : Integer;
  1608.   sr : SearchRec;
  1609.   ExpandedName : PathStr;
  1610. begin
  1611.   with aBinding do
  1612.     begin
  1613.       Name := TextRec (f).Name;
  1614.       p := Pos (#0, Name);
  1615.       if p <> 0 then Name [0] := Chr (p - 1);
  1616.       ExpandedName := FExpand (Name);
  1617.       { GetFTime works only on opened files, and FileSize doesn't work on
  1618.         text files, so we have to get this information via FindFirst }
  1619.       FindFirst (Name, Dos.AnyFile - VolumeID, sr);
  1620.       if DosError = 0 then
  1621.         begin
  1622.           UnPackTime (sr.Time, dt);
  1623.           with dt do
  1624.             begin
  1625.               y2 := Year - Ord (Month <= 2);
  1626.               ModificationTime := Sec + 60 * (Min + 60 * (Hour + 24 *
  1627.                                     LongInt (Day - 1 + MonthOffset [Month] +
  1628.                                       365 * (LongInt (Year) - 1970) + (y2 - 1968) div 4 -
  1629.                                              (y2 - 1900) div 100 + (y2 - 1600) div 400)))
  1630.             end;
  1631.           Attr := sr.Attr
  1632.         end
  1633.       else
  1634.         begin
  1635.           ModificationTime := - 1;
  1636.           Attr := 0
  1637.         end;
  1638.       Bound            := True;
  1639.       Force            := False;
  1640.       Extensions_Valid := True;
  1641.       Existing         := (DosError = 0) and (Attr and Dos.Directory = 0);
  1642.       Readable         := Existing;
  1643.       Writable         := (DosError <> 0) or (Attr and (Dos.Directory or ReadOnly) = 0);
  1644.                           { we pretend any non-existing file is writable, which is not exactly true ;-}
  1645.       Directory        := (DosError = 0) and (Attr and  Dos.Directory <> 0);
  1646.       Special          := False; (*@@should check for Dos devices, and unset Existing if it is one*)
  1647.       SymLink          := False;
  1648.       Executable       := Directory;
  1649.       Size             := sr.Size;
  1650.       AccessTime       := ModificationTime;
  1651.       ChangeTime       := ModificationTime;
  1652.       User             := - 1;
  1653.       Group            := - 1;
  1654.       Mode             := 0;
  1655.       if Readable   then Mode := Mode or fm_UserReadable or fm_GroupReadable or fm_OthersReadable;
  1656.       if Writable   then Mode := Mode or fm_UserWritable;
  1657.       if Executable then Mode := Mode or fm_UserExecutable or fm_GroupExecutable or fm_OthersExecutable;
  1658.       Device           := Ord (UpCase (ExpandedName [1])) - Ord ('A') + 1;
  1659.       INode            := - 1;
  1660.       TextBinary       := False;
  1661.       Handle           := - 1
  1662.     end
  1663. end;
  1664.  
  1665. function IsLeapYear (Year : Integer) : Boolean;
  1666. begin
  1667.   IsLeapYear := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0))
  1668. end;
  1669.  
  1670. function MonthLength (Month, Year : Integer) : Integer;
  1671. const
  1672.   MonthLengths : array [1 .. 12] of Integer =
  1673.     (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  1674. begin
  1675.   if (Month < 1) or (Month > 12)
  1676.     then MonthLength := 0
  1677.     else MonthLength := MonthLengths [Month] + Ord ((Month = 2) and IsLeapYear (Year))
  1678. end;
  1679.  
  1680. procedure Sleep (Seconds : Integer);
  1681. begin
  1682.   Delay (1000 * Seconds)
  1683. end;
  1684.  
  1685. procedure SleepMicroSeconds (MicroSeconds : LongInt);
  1686. begin
  1687.   if MicroSeconds > 0 then
  1688.     Delay ((MicroSeconds + 500) div 1000)
  1689. end;
  1690.  
  1691. function GetMicroSecondTime : MicroSecondTimeType;
  1692. var
  1693.   Year, Month, Day, DOW, Hour, Min, Sec, Sec100 : Word;
  1694.   y2 : Integer;
  1695.   Seconds : LongInt;
  1696. begin
  1697.   GetDate (Year, Month, Day, DOW);
  1698.   GetTime (Hour, Min, Sec, Sec100);
  1699.   y2 := Year - Ord (Month <= 2);
  1700.   Seconds := Sec + 60 * (Min + 60 * (Hour + 24 *
  1701.                LongInt (Day - 1 + MonthOffset [Month] +
  1702.                  365 * (LongInt (Year) - 1970) + (y2 - 1968) div 4 -
  1703.                         (y2 - 1900) div 100 + (y2 - 1600) div 400)));
  1704.   GetMicroSecondTime := 1000000.0 * Seconds + 10000 * LongInt (Sec100)
  1705. end;
  1706.  
  1707. function GetCPUTime (var MicroSecond { : LongInt }) : LongInt;
  1708. var
  1709.   h, m, s, s100 : Word;
  1710.   Seconds, MicroSeconds : LongInt;
  1711. begin
  1712.   GetTime (h, m, s, s100);
  1713.   Seconds := (LongInt (h) * 60 + m) * 60 + s - StartCPUTimeSeconds;
  1714.   MicroSeconds := 10000 * LongInt (s100) - StartCPUTimeMicroSeconds;
  1715.   if MicroSeconds < 0 then
  1716.     begin
  1717.       Dec (Seconds);
  1718.       Inc (MicroSeconds, 1000000)
  1719.     end;
  1720.   if @MicroSecond <> nil then LongInt (MicroSecond) := MicroSeconds;
  1721.   GetCPUTime := Seconds
  1722. end;
  1723.  
  1724. function AddDirSeparator (s : String) : TString;
  1725. begin
  1726.   if (s <> '') and not (s [Length (s)] in DirSeparators)
  1727.     and DirectoryExists (s) then s := s + DirSeparator;
  1728.   AddDirSeparator := s
  1729. end;
  1730.  
  1731. function RemoveDirSeparator (s : String) : TString;
  1732. begin
  1733.   if (s <> '') and (s [Length (s)] in DirSeparators) then
  1734.     Delete (s, Length (s), 1);
  1735.   RemoveDirSeparator := s
  1736. end;
  1737.  
  1738. function GetCurrentDirectory : TString;
  1739. begin
  1740.   GetCurrentDirectory := FExpand (DirSelf)
  1741. end;
  1742.  
  1743. function GetTempDirectory : TString;
  1744. const TempDirectory : String = '';
  1745.  
  1746.   function CheckDir (const s : String) : Boolean;
  1747.   begin
  1748.     TempDirectory := s;
  1749.     if TempDirectory = '' then
  1750.       begin
  1751.         CheckDir := False;
  1752.         Exit
  1753.       end;
  1754.     if TempDirectory [Length (TempDirectory)] <> DirSeparator then
  1755.       TempDirectory := TempDirectory + DirSeparator;
  1756.     CheckDir := DirectoryExists (TempDirectory)
  1757.   end;
  1758.  
  1759. begin
  1760.   if not (
  1761.            CheckDir (TempDirectory) or
  1762.            CheckDir (GetEnv ('TEMP')) or
  1763.            CheckDir (GetEnv ('TMP')) or
  1764.            CheckDir (GetEnv ('TEMPDIR')) or
  1765.            CheckDir (GetEnv ('TMPDIR')) or
  1766.            CheckDir ('c:\temp\') or
  1767.            CheckDir ('c:\tmp\') or
  1768.            CheckDir ('\temp\') or
  1769.            CheckDir ('\tmp\') or
  1770.            CheckDir ('.\')
  1771.          ) then TempDirectory := '';
  1772.   GetTempDirectory := TempDirectory
  1773. end;
  1774.  
  1775. function ExpandEnvironment (var s : String) : Boolean;
  1776. var
  1777.   p, q : Integer;
  1778.   EnvName, Env : TString;
  1779. begin
  1780.   p := 0;
  1781.   repeat
  1782.     repeat
  1783.       Inc (p);
  1784.       if p > Length (s) then
  1785.         begin
  1786.           ExpandEnvironment := True;
  1787.           Exit
  1788.         end
  1789.     until (s [p] = '$') or ((p = 1) and (s [p] = '~'));
  1790.     q := p + 1;
  1791.     if s [p] = '~' then
  1792.       EnvName := 'HOME'
  1793.     else
  1794.       begin
  1795.         if (q <= Length (s)) and (s [q] in EnvVarCharsFirst) then
  1796.           while (q <= Length (s)) and (s [q] in EnvVarChars) do Inc (q);
  1797.         EnvName := Copy (s, p + 1, q - p - 1)
  1798.       end;
  1799.     Delete (s, p, q - p);
  1800.     Env := GetEnv (EnvName);
  1801.     if Env = '' then
  1802.       begin
  1803.         s := EnvName;
  1804.         ExpandEnvironment := False;
  1805.         Exit
  1806.       end;
  1807.     Insert (Env, s, p)
  1808.   until False
  1809. end;
  1810.  
  1811. function FileExists (const aFileName : String) : Boolean;
  1812. var
  1813.   f : File;
  1814.   Attr : TDosAttr;
  1815. begin
  1816.   Assign (f, aFileName);
  1817.   GetFAttr (f, Attr);
  1818.   FileExists := (DosError = 0) and (Attr and Directory = 0)
  1819. end;
  1820.  
  1821. function DirectoryExists (aFileName : String) : Boolean;
  1822. var
  1823.   f : File;
  1824.   Attr : TDosAttr;
  1825. begin
  1826.   if (Length (aFileName) > 3) and (aFileName [Length (aFileName)] = DirSeparator) then
  1827.     Delete (aFileName, Length (aFileName), 1);
  1828.   Assign (f, aFileName);
  1829.   GetFAttr (f, Attr);
  1830.   DirectoryExists := (DosError = 0) and (Attr and Directory <> 0)
  1831. end;
  1832.  
  1833. function PathExists (const aFileName : String) : Boolean;
  1834. var
  1835.   f : File;
  1836.   Attr : TDosAttr;
  1837. begin
  1838.   Assign (f, aFileName);
  1839.   GetFAttr (f, Attr);
  1840.   PathExists := DosError = 0
  1841. end;
  1842.  
  1843. function RelativePath (const Path : String; OnlyCurDir, Quoted : Boolean) : TString;
  1844. var Res, p : TString;
  1845. begin
  1846.   Res := FExpand (Path);
  1847.   p := AddDirSeparator (FExpand (DirSelf));
  1848.   if (Length (Res) >= Length (p)) and
  1849.     (Copy (Res, 1, Length (p)) = p) and
  1850.     (not OnlyCurDir or (LastCharPos (DirSeparators, Res) <= Length (p))) then
  1851.     Delete (Res, 1, Length (p));
  1852.   RelativePath := Res
  1853. end;
  1854.  
  1855. function DirFromPath (const Path : String) : TString;
  1856. var Dir, Name, Ext : TString;
  1857. begin
  1858.   FSplit (Path, Dir, Name, Ext);
  1859.   if Dir = '' then Dir := DirSelf + DirSeparator;
  1860.   DirFromPath := Dir
  1861. end;
  1862.  
  1863. function NameFromPath (const Path : String) : TString;
  1864. var Dir, Name, Ext : TString;
  1865. begin
  1866.   FSplit (Path, Dir, Name, Ext);
  1867.   NameFromPath := Name
  1868. end;
  1869.  
  1870. function ExtFromPath (const Path : String) : TString;
  1871. var Dir, Name, Ext : TString;
  1872. begin
  1873.   FSplit (Path, Dir, Name, Ext);
  1874.   ExtFromPath := Ext
  1875. end;
  1876.  
  1877. function NameExtFromPath (const Path : String) : TString;
  1878. var Dir, Name, Ext : TString;
  1879. begin
  1880.   FSplit (Path, Dir, Name, Ext);
  1881.   NameExtFromPath := Name + Ext
  1882. end;
  1883.  
  1884. function OpenDir (Name : String) : DirPtr;
  1885. var Dir : DirPtr;
  1886. begin
  1887.   New (Dir);
  1888.   FindFirst (AddDirSeparator (Name) + '*.*', Dos.AnyFile - VolumeID, Dir^);
  1889.   if DosError <> 0 then
  1890.     begin
  1891.       Dispose (Dir);
  1892.       InOutRes := 100;
  1893.       Dir := nil
  1894.     end;
  1895.   OpenDir := Dir
  1896. end;
  1897.  
  1898. function ReadDir (Dir : DirPtr) : TString;
  1899. begin
  1900.   ReadDir := LoCaseStr (Dir^.Name);
  1901.   if Dir^.Name <> '' then
  1902.     begin
  1903.       FindNext (Dir^);
  1904.       if DosError <> 0 then Dir^.Name := ''
  1905.     end
  1906. end;
  1907.  
  1908. procedure CloseDir (Dir : DirPtr);
  1909. begin
  1910.   if Dir <> nil then Dispose (Dir)
  1911. end;
  1912.  
  1913. function HasWildCards (const s : String) : Boolean;
  1914. begin
  1915.   HasWildCards := CharPos (WildCardChars, s) <> 0
  1916. end;
  1917.  
  1918. function FileNameMatch (const Pattern, Name : String) : Boolean;
  1919. var
  1920.   zp, zn, z2 : Integer;
  1921.   ch : Char;
  1922.   s : set of Char;
  1923.   Negate : Boolean;
  1924.   Pattern2 : TString;
  1925. begin
  1926.   FileNameMatch := False;
  1927.   zn := 1;
  1928.   zp := 1;
  1929.   while zp <= Length (Pattern) do
  1930.     begin
  1931.       ch := Pattern [zp];
  1932.       Inc (zp);
  1933.       if ch = '*' then
  1934.         begin
  1935.           while (zp <= Length (Pattern)) and (Pattern [zp] = '*') do Inc (zp);
  1936.           Pattern2 := Copy (Pattern, zp, Length (Pattern) - zp + 1);
  1937.           for z2 := Length (Name) + 1 downto zn do
  1938.             if FileNameMatch (Pattern2, Copy (Name, z2, Length (Name) - z2 + 1)) then
  1939.               begin
  1940.                 FileNameMatch := True;
  1941.                 Exit
  1942.               end;
  1943.           Exit
  1944.         end;
  1945.       if zn > Length (Name) then Exit;
  1946.       if ch = '['
  1947.       then
  1948.         begin
  1949.           Negate := (zp <= Length (Pattern)) and (Pattern [zp] = '^');
  1950.           if Negate then Inc (zp);
  1951.           s := [];
  1952.           while (zp <= Length (Pattern)) and (Pattern [zp] <> ']') do
  1953.             begin
  1954.               ch := Pattern [zp];
  1955.               Inc (zp);
  1956.               if Pattern [zp] = '-'
  1957.                 then
  1958.                   begin
  1959.                     s := s + [ch .. Pattern [zp + 1]];
  1960.                     Inc (zp, 2)
  1961.                   end
  1962.                 else s := s + [ch]
  1963.             end;
  1964.           Inc (zp);
  1965.           if not (Name [zn] in s) xor Negate then Exit
  1966.         end
  1967.       else
  1968.         if (Name [zn] <> ch) and (ch <> '?') then Exit;
  1969.       Inc (zn)
  1970.     end;
  1971.   FileNameMatch := zn > Length (Name)
  1972. end;
  1973.  
  1974. function ConfigFileName (Prefix, Name : String; Global : Boolean) : TString;
  1975. var Dir, PName, Ext : TString;
  1976. begin
  1977.   FSplit (LoCaseStr (ParamStr (0)), Dir, PName, Ext);
  1978.   if Name <> '' then PName := Name;
  1979.   if Global
  1980.     then ConfigFileName := Dir + PName + '.ini'
  1981.     else ConfigFileName := Dir + PName + '.cfg'
  1982. end;
  1983.  
  1984. function DataDirectoryName (Prefix, Name : String) : TString;
  1985. begin
  1986.   DataDirectoryName := DirFromPath (LoCaseStr (ParamStr (0)))
  1987. end;
  1988.  
  1989. procedure GetTimeStamp (var aTimeStamp : TimeStamp);
  1990. var y, m, d, dow, h, mi, s, s100 : Word;
  1991. begin
  1992.   GetDate (y, m, d, dow);
  1993.   GetTime (h, mi, s, s100);
  1994.   with aTimeStamp do
  1995.     begin
  1996.       DateValid   := True;
  1997.       TimeValid   := True;
  1998.       Year        := y;
  1999.       Month       := m;
  2000.       Day         := d;
  2001.       DayOfWeek   := dow;
  2002.       Hour        := h;
  2003.       Minute      := mi;
  2004.       Second      := s;
  2005.       MicroSecond := 10000 * s100
  2006.     end
  2007. end;
  2008.  
  2009. procedure CheckInOutRes;
  2010. var Temp : Integer;
  2011. begin
  2012.   Temp := IOResult;
  2013.   if Temp <> 0 then RunError (Temp)
  2014. end;
  2015.  
  2016. const
  2017.   E_CloseIgnore = 103;
  2018.  
  2019. function GetIOErrorMessage : TString;
  2020. const
  2021.   ErrMsgs : array [1 .. 35] of record
  2022.     Code : Integer;
  2023.     MsgStr : String
  2024.   end =
  2025.     ((Code :   1; MsgStr : 'Invalid Dos function code'),
  2026.      (Code :   4; MsgStr : 'Too many open files'),
  2027.      (Code :   6; MsgStr : 'Invalid file handle'),
  2028.      (Code :   8; MsgStr : 'Not enough memory'),
  2029.      (Code :  12; MsgStr : 'Invalid file access code'),
  2030.      (Code :  15; MsgStr : 'Invalid drive number'),
  2031.      (Code :  16; MsgStr : 'Cannot remove current directory'),
  2032.      (Code :  17; MsgStr : 'Cannot rename across drives'),
  2033.      (Code : 100; MsgStr : 'Disk read error'),
  2034.      (Code : 101; MsgStr : 'Disk write error'),
  2035.      (Code : 102; MsgStr : 'File not assigned'),
  2036.      (Code : 103; MsgStr : 'File not open'),
  2037.      (Code : 104; MsgStr : 'File not open for input'),
  2038.      (Code : 105; MsgStr : 'File not open for output'),
  2039.      (Code : 106; MsgStr : 'Invalid numeric format'),
  2040.      (Code : 150; MsgStr : 'Disk is write-protected'),
  2041.      (Code : 152; MsgStr : 'Drive not ready'),
  2042.      (Code : 154; MsgStr : 'CRC error in data'),
  2043.      (Code : 156; MsgStr : 'Disk seek error'),
  2044.      (Code : 158; MsgStr : 'Sector not found'),
  2045.      (Code : 159; MsgStr : 'Printer out of paper'),
  2046.      (Code : 160; MsgStr : 'Device write fault'),
  2047.      (Code : 161; MsgStr : 'Device read fault'),
  2048.      (Code : 162; MsgStr : 'Hardware failure'),
  2049.      (Code : 200; MsgStr : 'Division by zero'),
  2050.      (Code : 201; MsgStr : 'Range check error'),
  2051.      (Code : 202; MsgStr : 'Stack overflow error'),
  2052.      (Code : 203; MsgStr : 'Out of memory'),
  2053.      (Code : 204; MsgStr : 'Invalid pointer operation'),
  2054.      (Code : 205; MsgStr : 'Floating point overflow'),
  2055.      (Code : 206; MsgStr : 'Floating point underflow'),
  2056.      (Code : 207; MsgStr : 'Invalid floating point operation'),
  2057.      (Code : 208; MsgStr : 'Overlay manager not installed'),
  2058.      (Code : 209; MsgStr : 'Overlay file read error'),
  2059.      (Code : 210; MsgStr : 'Object not initialized'));
  2060. var i, n : Integer;
  2061. begin
  2062.   n := IOResult;
  2063.   i := Low (ErrMsgs);
  2064.   while (i <= High (ErrMsgs)) and (ErrMsgs [i].Code <> n) do Inc (i);
  2065.   if i <= High (ErrMsgs)
  2066.     then GetIOErrorMessage := ErrMsgs [i].MsgStr
  2067.     else GetIOErrorMessage := 'Unknown error code'
  2068. end;
  2069.  
  2070. procedure Close (var f : Text);
  2071. var Res : Integer;
  2072. begin
  2073.   Res := IOResult;
  2074.   System.Close (f);
  2075.   if (Res <> 0) or (InOutRes = E_CloseIgnore) then InOutRes := Res
  2076. end;
  2077.  
  2078. procedure CloseFile (var f : File);
  2079. var Res : Integer;
  2080. begin
  2081.   Res := IOResult;
  2082.   System.Close (f);
  2083.   if (Res <> 0) or (InOutRes = E_CloseIgnore) then InOutRes := Res
  2084. end;
  2085.  
  2086. { TFDD (interface may be subject to change) }
  2087.  
  2088. type
  2089.   TTFDDUserData = record
  2090.     fReadFunc    : TReadFunc;
  2091.     fWriteFunc   : TWriteFunc;
  2092.     fFlushProc   : TFlushProc;
  2093.     fPrivateData : Pointer;
  2094.   end;
  2095.  
  2096.   { UserData does not have enough room for all our pointers, so we store
  2097.     some of them in the Name field. This is a very dirty hack, but well...
  2098.     it's only BP ;-}
  2099.   TTFDDUserDataName = record
  2100.     Unused       : Pointer; { Don't use the first byte, we store a #0 there }
  2101.     fOpenProc    : TOpenProc;
  2102.     fCloseProc   : TCloseProc;
  2103.     Fill         : array [12 .. 79] of Char
  2104.   end;
  2105.  
  2106. function TFDDInput (var f : TextRec) : Integer;
  2107. begin
  2108.   f.BufPos := 0;
  2109.   with TTFDDUserData (f.UserData) do
  2110.     if @fReadFunc = nil
  2111.       then f.BufEnd := 0
  2112.       else f.BufEnd := fReadFunc (fPrivateData^, f.BufPtr^, f.BufSize);
  2113.   TFDDInput := IOResult
  2114. end;
  2115.  
  2116. function TFDDOutput (var f : TextRec) : Integer;
  2117. var
  2118.   p : PChar;
  2119.   Size : SizeType;
  2120.   Res : Integer;
  2121. begin
  2122.   p := PChar (f.BufPtr);
  2123.   Size := f.BufPos;
  2124.   while (InOutRes = 0) and (Size > 0) do
  2125.     begin
  2126.       with TTFDDUserData (f.UserData) do
  2127.         if @fWriteFunc = nil
  2128.           then Res := 0
  2129.           else Res := fWriteFunc (fPrivateData^, p^, Size);
  2130.       Dec (Size, Res);
  2131.       Inc (p, Res);
  2132.       if (Res = 0) and (InOutRes = 0) then InOutRes := 100 { Disk read error }
  2133.     end;
  2134.   f.BufPos := 0;
  2135.   TFDDOutput := IOResult
  2136. end;
  2137.  
  2138. function TFDDFlush (var f : TextRec) : Integer;
  2139. begin
  2140.   InOutRes := TFDDOutput (f);
  2141.   if InOutres = 0 then
  2142.     with TTFDDUserData (f.UserData) do
  2143.       if @fFlushProc <> nil then fFlushProc (fPrivateData^);
  2144.   TFDDFlush := IOResult
  2145. end;
  2146.  
  2147. function TFDDDummy (var f : TextRec) : Integer;
  2148. begin
  2149.   TFDDDummy := IOResult
  2150. end;
  2151.  
  2152. function TFDDClose (var f : TextRec) : Integer;
  2153. begin
  2154.   with TTFDDUserData (f.UserData), TTFDDUserDataName (f.Name) do
  2155.     if @fCloseProc <> nil then fCloseProc (fPrivateData^);
  2156.   TFDDClose := IOResult
  2157. end;
  2158.  
  2159. function TFDDOpen (var f : TextRec) : Integer;
  2160. var Mode : TOpenMode;
  2161. begin
  2162.   if f.Mode = fmInput then
  2163.     begin
  2164.       f.InOutFunc := @TFDDInput;
  2165.       f.FlushFunc := @TFDDDummy;
  2166.       Mode := foReset
  2167.     end
  2168.   else
  2169.     begin
  2170.       f.InOutFunc := @TFDDOutput;
  2171.       f.FlushFunc := @TFDDFlush;
  2172.       if f.Mode = fmOutput
  2173.         then Mode := foRewrite
  2174.         else Mode := foAppend;
  2175.       f.Mode := fmOutput
  2176.     end;
  2177.   f.CloseFunc := @TFDDClose;
  2178.   with TTFDDUserData (f.UserData), TTFDDUserDataName (f.Name) do
  2179.     if @fOpenProc <> nil then fOpenProc (fPrivateData^, Mode);
  2180.   TFDDOpen := IOResult
  2181. end;
  2182.  
  2183. procedure AssignTFDD (var f : AnyFile;
  2184.                       OpenProc    : TOpenProc;
  2185.                       SelectFunc  : TSelectFunc; { will not be called in BP! }
  2186.                       SelectProc  : TSelectProc; { will not be called in BP! }
  2187.                       ReadFunc    : TReadFunc;
  2188.                       WriteFunc   : TWriteFunc;
  2189.                       FlushProc   : TFlushProc;
  2190.                       CloseProc   : TCloseProc;
  2191.                       DoneProc    : TDoneProc;   { will not be called in BP! }
  2192.                       PrivateData : Pointer);
  2193. begin
  2194.   with TextRec (f), TTFDDUserData (UserData), TTFDDUserDataName (Name) do
  2195.     begin
  2196.       Handle := $ffff;
  2197.       Mode := fmClosed;
  2198.       BufSize := SizeOf (Buffer);
  2199.       BufPtr := @Buffer;
  2200.       OpenFunc := @TFDDOpen;
  2201.       fOpenProc    := OpenProc;
  2202.       fReadFunc    := ReadFunc;
  2203.       fWriteFunc   := WriteFunc;
  2204.       fFlushProc   := FlushProc;
  2205.       fCloseProc   := CloseProc;
  2206.       fPrivateData := PrivateData;
  2207.       Name [0] := #0
  2208.     end
  2209. end;
  2210.  
  2211. { Strings extensions }
  2212.  
  2213. function CString2String (Str : CString) : TString;
  2214. begin
  2215.   CString2String := StrPas (Str)
  2216. end;
  2217.  
  2218. { Printer extensions }
  2219.  
  2220. procedure AssignLst (var f : Text);
  2221. begin
  2222.   Assign (f, 'LPT1');
  2223.   Rewrite (f);
  2224.   asm
  2225.      mov  bx, f.TextRec.Handle
  2226.      mov  ax, $4400
  2227.      int  $21
  2228.      or   dl, $20
  2229.      mov  dh, 0
  2230.      mov  ax, $4401
  2231.      int  $21
  2232.   end
  2233. end;
  2234.  
  2235. { GetOpt -- very primitive }
  2236.  
  2237. function GetOpt (OptString : CString) : Char;
  2238. var
  2239.   OptStr, s : String;
  2240.   p, o : Integer;
  2241. begin
  2242.   if FirstNonOption = 0 then FirstNonOption := 1;
  2243.   GetOpt := EndOfOptions;
  2244.   OptionArgument := '';
  2245.   HasOptionArgument := False;
  2246.   if FirstNonOption > ParamCount then Exit;
  2247.   OptStr := CString2String (OptString);
  2248.   s := ParamStr (FirstNonOption);
  2249.   if (Length (s) < 2) or (s [1] <> '-') then
  2250.     begin
  2251.       if OptStr [1] = '-' then
  2252.         begin
  2253.           GetOpt := NoOption;
  2254.           OptionArgument := s;
  2255.           HasOptionArgument := True;
  2256.           Inc (FirstNonOption)
  2257.         end;
  2258.       Exit
  2259.     end;
  2260.   Inc (FirstNonOption);
  2261.   p := Pos (s [2], OptStr);
  2262.   if p = 0 then
  2263.     begin
  2264.       GetOpt := UnknownOption;
  2265.       UnknownOptionCharacter := s [2];
  2266.       if GetOptErrorFlag then Writeln (StdErr, ParamStr (0), ': unrecognized option -- ', s [2]);
  2267.       Exit
  2268.     end;
  2269.   GetOpt := s [2];
  2270.   Inc (p);
  2271.   o := p;
  2272.   while (o <= Length (OptStr)) and (OptStr [o] = ':') do Inc (o);
  2273.   Dec (o, p);
  2274.   if o = 0 then
  2275.     begin
  2276.       if (Length (s) > 2) and GetOptErrorFlag then
  2277.         Writeln (StdErr, ParamStr (0), ': ignoring `', Copy (s, 3, Length (s) - 2), ''' after `-', s [2], '''');
  2278.       Exit
  2279.     end;
  2280.   if Length (s) > 2 then
  2281.     begin
  2282.       OptionArgument := Copy (s, 2, Length (s) - 2);
  2283.       HasOptionArgument := True
  2284.     end
  2285.   else
  2286.     if o = 1 then
  2287.       begin
  2288.         OptionArgument := ParamStr (FirstNonOption);
  2289.         HasOptionArgument := FirstNonOption <= ParamCount;
  2290.         if FirstNonOption <= ParamCount then Inc (FirstNonOption)
  2291.       end
  2292. end;
  2293.  
  2294. { Dos extensions }
  2295.  
  2296. procedure FindFirst (const Path : String; Attr : Word; var SR : SearchRec);
  2297. var i : Integer;
  2298. begin
  2299.   Dos.FindFirst (Path, Attr, SR);
  2300.   for i := Low (SR.Name) to High (SR.Name) do SR.Name [i] := LoCase (SR.Name [i])
  2301. end;
  2302.  
  2303. procedure FindNext  (var SR : SearchRec);
  2304. var i : Integer;
  2305. begin
  2306.   Dos.FindNext (SR);
  2307.   for i := Low (SR.Name) to High (SR.Name) do SR.Name [i] := LoCase (SR.Name [i])
  2308. end;
  2309.  
  2310. procedure FindClose (var SR : SearchRec);
  2311. begin
  2312. end;
  2313.  
  2314. function FExpand (const Path : String) : TString;
  2315. var d, n, e, s : TString;
  2316. begin
  2317.   FSplit (Path, d, n, e);
  2318.   if not DirectoryExists (d) then
  2319.     FExpand := ''
  2320.   else
  2321.     begin
  2322.       s := LoCaseStr (Dos.FExpand (Path));
  2323.       if s [Length (s)] = ExtSeparator then Delete (s, Length (s), 1);
  2324.       FExpand := s
  2325.     end
  2326. end;
  2327.  
  2328. {$P+}
  2329. procedure FSplit (const Path : String; var Dir, Name, Ext : String);
  2330. var
  2331.   aDir  : DirStr;
  2332.   aName : NameStr;
  2333.   aExt  : ExtStr;
  2334. begin
  2335.   Dos.FSplit (Path, aDir, aName, aExt);
  2336.   Dir  := aDir;
  2337.   Name := aName;
  2338.   Ext  := aExt
  2339. end;
  2340. {$P-}
  2341.  
  2342. function GetEnv (const EnvVar : String) : TString;
  2343. begin
  2344.   GetEnv := Dos.GetEnv (EnvVar)
  2345. end;
  2346.  
  2347. procedure SwapVectors;
  2348. begin
  2349. end;
  2350.  
  2351. {$ifdef MSDOS}
  2352. procedure SetMemTop (MemTop : Pointer); assembler;
  2353. asm
  2354.    les  bx, MemTop
  2355.    mov  ax, es
  2356.    add  bx, 15
  2357.    mov  cl, 4
  2358.    shr  bx, cl
  2359.    add  bx, ax
  2360.    mov  ax, PrefixSeg
  2361.    sub  bx, ax
  2362.    mov  es, ax
  2363.    mov  ah, $4a
  2364.    int  $21
  2365. end;
  2366. {$endif}
  2367.  
  2368. procedure Exec (const Path, ComLine : String);
  2369. begin
  2370.   RestoreTerminal (True);
  2371.   {$ifdef MSDOS} SetMemTop (HeapPtr); {$endif}
  2372.   Dos.SwapVectors;
  2373.   Dos.Exec (Path, ComLine);
  2374.   Dos.SwapVectors;
  2375.   {$ifdef MSDOS} SetMemTop (HeapEnd); {$endif}
  2376.   RestoreTerminal (False)
  2377. end;
  2378.  
  2379. function Execute (CmdLine : String) : Integer;
  2380. begin
  2381.   Exec (GetEnv (ShellEnvVar), ShellExecCommand + ' ' + CmdLine);
  2382.   InOutRes := DosError;
  2383.   Execute := DosExitCode
  2384. end;
  2385.  
  2386. type
  2387.   PRestoreTerminalProcs = ^TRestoreTerminalProcs;
  2388.   TRestoreTerminalProcs = record
  2389.     Next, Prev : PRestoreTerminalProcs;
  2390.     Proc : TProcedure
  2391.   end;
  2392.  
  2393. const
  2394.   RestoreTerminalProcs : array [Boolean] of PRestoreTerminalProcs = (nil, nil);
  2395.  
  2396. procedure RegisterRestoreTerminal (ForAnotherProcess : Boolean; Proc : TProcedure);
  2397. var p : PRestoreTerminalProcs;
  2398. begin
  2399.   New (p);
  2400.   p^.Proc := Proc;
  2401.   p^.Prev := nil;
  2402.   p^.Next := RestoreTerminalProcs [ForAnotherProcess];
  2403.   if p^.Next <> nil then p^.Next^.Prev := p;
  2404.   RestoreTerminalProcs [ForAnotherProcess] := p
  2405. end;
  2406.  
  2407. function UnregisterRestoreTerminal (ForAnotherProcess : Boolean; Proc : TProcedure) : Boolean;
  2408. var p : PRestoreTerminalProcs;
  2409. begin
  2410.   p := RestoreTerminalProcs [ForAnotherProcess];
  2411.   while (p <> nil) and (@p^.Proc <> @Proc) do p := p^.Next;
  2412.   if p = nil then
  2413.     UnregisterRestoreTerminal := False
  2414.   else
  2415.     begin
  2416.       if p^.Next <> nil then p^.Next^.Prev := p^.Prev;
  2417.       if p^.Prev = nil
  2418.         then RestoreTerminalProcs [ForAnotherProcess] := p^.Next
  2419.         else p^.Prev^.Next := p^.Next;
  2420.       Dispose (p);
  2421.       UnregisterRestoreTerminal := True
  2422.     end
  2423. end;
  2424.  
  2425. procedure RestoreTerminal (ForAnotherProcess : Boolean);
  2426. var p : PRestoreTerminalProcs;
  2427. begin
  2428.   p := RestoreTerminalProcs [ForAnotherProcess];
  2429.   if ForAnotherProcess then
  2430.     while p <> nil do
  2431.       begin
  2432.         p^.Proc;
  2433.         p := p^.Next
  2434.       end
  2435.   else if p <> nil then
  2436.     begin
  2437.       while p^.Next <> nil do p := p^.Next;
  2438.       while p <> nil do
  2439.         begin
  2440.           p^.Proc;
  2441.           p := p^.Prev
  2442.         end
  2443.     end
  2444. end;
  2445.  
  2446. { CRT extensions }
  2447.  
  2448. const
  2449.   MonoModes = [BW40, BW80, Mono];
  2450.   MaxScreenSize = MaxInt;
  2451.   CurrentCursorShape : TCursorShape = CursorNormal;
  2452.  
  2453. type
  2454.   TScreenChar = record
  2455.     ScrCh : Char;
  2456.     Attrib : TTextAttr
  2457.   end;
  2458.  
  2459.   TScreenBuffer = array [0 .. MaxScreenSize - 1] of TScreenChar;
  2460.  
  2461. var
  2462.   CRTOutFile : Text;
  2463.   OrigCursor : Word;
  2464.   ScreenBuffer : ^TScreenBuffer;
  2465.   KBReadFunc : Byte;
  2466.  
  2467. function GetShiftState : Integer;
  2468. var State : Integer;
  2469. begin
  2470.   State := Mem [Seg0040 : $17] and (shShift or shCtrl or shAlt);
  2471.   GetShiftState := VirtualShiftState or State or ((State and shAlt) * (shAltGr div shAlt))
  2472. end;
  2473.  
  2474. procedure SetCRTUpdate (Update : TCRTUpdate);
  2475. begin
  2476. end;
  2477.  
  2478. procedure CRTUpdate;
  2479. begin
  2480. end;
  2481.  
  2482. function ReadKeyWord : TKey;
  2483. var k : TKey;
  2484. begin
  2485.   asm
  2486.      mov ah, KBReadFunc
  2487.      int $16
  2488.      mov k, ax
  2489.   end;
  2490.   if (Lo (k) = $e0) and (Hi (k) >= 70) then k := k and $ff00;
  2491.   if Lo (k) <> 0 then k := k and $ff;
  2492.   case k of
  2493.     kbIns : if GetShiftState and shShift <> 0 then k := kbShIns;
  2494.     kbDel : if GetShiftState and shShift <> 0 then k := kbShDel;
  2495.   end;
  2496.   ReadKeyWord := k
  2497. end;
  2498.  
  2499. function Key2Char (k : TKey) : Char;
  2500. begin
  2501.   if k div $100 <> 0
  2502.     then Key2Char := #0
  2503.     else Key2Char := Chr (k)
  2504. end;
  2505.  
  2506. function Key2Scan (k : TKey) : Char;
  2507. begin
  2508.   Key2Scan := Chr (k div $100)
  2509. end;
  2510.  
  2511. function UpCaseKey (k : TKey) : TKey;
  2512. var ch : Char;
  2513. begin
  2514.   ch := Key2Char (k);
  2515.   if ch = #0
  2516.     then UpCaseKey := k
  2517.     else UpCaseKey := Ord (UpCase (ch))
  2518. end;
  2519.  
  2520. function LoCaseKey (k : TKey) : TKey;
  2521. var ch : Char;
  2522. begin
  2523.   ch := Key2Char (k);
  2524.   if ch = #0
  2525.     then LoCaseKey := k
  2526.     else LoCaseKey := Ord (LoCase (ch))
  2527. end;
  2528.  
  2529. procedure GetWindow (var x1, y1, x2, y2 : Integer);
  2530. begin
  2531.   if @x1 <> nil then x1 := WindowMin.X + 1;
  2532.   if @y1 <> nil then y1 := WindowMin.Y + 1;
  2533.   if @x2 <> nil then x2 := WindowMax.X + 1;
  2534.   if @y2 <> nil then y2 := WindowMax.Y + 1
  2535. end;
  2536.  
  2537. function GetXMax : Integer;
  2538. var x1, x2 : Integer;
  2539. begin
  2540.   GetWindow (x1, null, x2, null);
  2541.   GetXMax := x2 - x1 + 1
  2542. end;
  2543.  
  2544. function GetYMax : Integer;
  2545. var y1, y2 : Integer;
  2546. begin
  2547.   GetWindow (null, y1, null, y2);
  2548.   GetYMax := y2 - y1 + 1
  2549. end;
  2550.  
  2551. function WhereXAbs : Integer;
  2552. var x1 : Integer;
  2553. begin
  2554.   GetWindow (x1, null, null, null);
  2555.   WhereXAbs := WhereX + x1 - 1
  2556. end;
  2557.  
  2558. function WhereYAbs : Integer;
  2559. var y1 : Integer;
  2560. begin
  2561.   GetWindow (null, y1, null, null);
  2562.   WhereYAbs := WhereY + y1 - 1
  2563. end;
  2564.  
  2565. procedure GotoXYAbs (X, Y : Integer);
  2566. var x1, y1 : Integer;
  2567. begin
  2568.   GetWindow (x1, y1, null, null);
  2569.   GotoXY (X - x1 + 1, Y - y1 + 1)
  2570. end;
  2571.  
  2572. procedure SetCursorShape (Shape : TCursorShape);
  2573.  
  2574.   procedure SetCursor (Cursor : Word); assembler;
  2575.   asm
  2576.      mov ah, 1
  2577.      mov cx, Cursor
  2578.      int $10
  2579.   end;
  2580.  
  2581. begin
  2582.   CurrentCursorShape := Shape;
  2583.   case Shape of
  2584.     CursorIgnored,
  2585.     CursorHidden : SetCursor ($2000);
  2586.     CursorNormal : SetCursor (OrigCursor);
  2587.     CursorFat    : SetCursor (OrigCursor and $ff + (OrigCursor div 2) and $ff00);
  2588.     CursorBlock  : SetCursor (OrigCursor and $ff);
  2589.   end
  2590. end;
  2591.  
  2592. function GetCursorShape : TCursorShape;
  2593. begin
  2594.   GetCursorShape := CurrentCursorShape
  2595. end;
  2596.  
  2597. procedure HideCursor;
  2598. begin
  2599.   SetCursorShape (CursorHidden)
  2600. end;
  2601.  
  2602. procedure HiddenCursor;
  2603. begin
  2604.   SetCursorShape (CursorHidden)
  2605. end;
  2606.  
  2607. procedure NormalCursor;
  2608. begin
  2609.   SetCursorShape (CursorNormal)
  2610. end;
  2611.  
  2612. procedure FatCursor;
  2613. begin
  2614.   SetCursorShape (CursorFat)
  2615. end;
  2616.  
  2617. procedure BlockCursor;
  2618. begin
  2619.   SetCursorShape (CursorBlock)
  2620. end;
  2621.  
  2622. procedure IgnoreCursor;
  2623. begin
  2624.   SetCursorShape (CursorIgnored)
  2625. end;
  2626.  
  2627. function GetTextColor : Integer;
  2628. begin
  2629.   GetTextColor := TextAttr and $8F
  2630. end;
  2631.  
  2632. function GetTextBackground : Integer;
  2633. begin
  2634.   GetTextBackground := (TextAttr and $70) shr 4
  2635. end;
  2636.  
  2637. procedure Flash;
  2638. var i, j : Integer;
  2639. begin
  2640.   for i := 1 to 2 do
  2641.     begin
  2642.       for j := 0 to ScreenSize.X * ScreenSize.Y - 1 do
  2643.         ScreenBuffer^[j].Attrib := ScreenBuffer^[j].Attrib xor $7f;
  2644.       Delay (10)
  2645.     end
  2646. end;
  2647.  
  2648. procedure Beep;
  2649. begin
  2650.   if VisualBell then
  2651.     Flash
  2652.   else
  2653.     begin
  2654.       Sound (2800);
  2655.       Delay (120);
  2656.       NoSound
  2657.     end
  2658. end;
  2659.  
  2660. procedure WriteChar (Ch : Char);
  2661. begin
  2662.   Write (CRTOutFile, Ch)
  2663. end;
  2664.  
  2665. procedure WriteString (const s : String; y, x : Integer);
  2666. var OrigX, OrigY : Integer;
  2667. begin
  2668.   OrigX := WhereX;
  2669.   OrigY := WhereY;
  2670.   GotoXY (x, y);
  2671.   Write (CRTOutFile, s);
  2672.   GotoXY (OrigX, OrigY)
  2673. end;
  2674.  
  2675. procedure FastWriteWindow (const s : String; y, x : Integer; Attr : TTextAttr);
  2676. begin
  2677.   WriteStrAt (x, y, s, Attr)
  2678. end;
  2679.  
  2680. procedure FastWrite (const s : String; y, x : Integer; Attr : TTextAttr);
  2681. begin
  2682.   WriteStrAt (x - WindowMin.X, y - WindowMin.Y, s, Attr)
  2683. end;
  2684.  
  2685. procedure ReadChar (x, y : Integer; var Ch : Char; var Attr : TTextAttr);
  2686. begin
  2687.   with ScreenBuffer^[(y + WindowMin.Y - 1) * Mem [Seg0040 : $4a] + x + WindowMin.X - 1] do
  2688.     begin
  2689.       Ch := ScrCh;
  2690.       Attr := Attrib
  2691.     end
  2692. end;
  2693.  
  2694. procedure TSync; near; assembler; { Registers: DX: Port }
  2695. asm
  2696. @1:in   al, dx
  2697.    test al, 1
  2698.    jne  @1
  2699.    cli
  2700. @2:in   al, dx
  2701.    test al, 1
  2702.    je   @2
  2703. end;
  2704.  
  2705. procedure CRTExtBlock; near; assembler; { Registers: CL: Buffer length; DX: Coordinates; SI: Procedure }
  2706. asm
  2707.    mov   es, Seg0040
  2708.    mov   al, dh
  2709.    mul   byte ptr es:[$4a]
  2710.    xor   dh, dh
  2711.    add   ax, dx
  2712.    shl   ax, 1
  2713.    mov   di, ax
  2714.    mov   es, Word ptr ScreenBuffer+2
  2715.    mov   dx, $3da
  2716.    cld
  2717.    cmp   CheckSnow, 1
  2718.    jmp   si
  2719. end;
  2720.  
  2721. procedure CRTExtScrOp; near; assembler; { Registers: CL: Buffer length; SI: Write procedure; BP: Stack frame }
  2722. asm
  2723.    mov   dl, [bp+14]
  2724.    dec   dl
  2725.    add   dl, WindowMin.X
  2726.    jc    @1
  2727.    cmp   dl, WindowMax.X
  2728.    ja    @1
  2729.    mov   dh, [bp+12]
  2730.    dec   dh
  2731.    add   dh, WindowMin.Y
  2732.    jc    @1
  2733.    cmp   dh, WindowMax.Y
  2734.    ja    @1
  2735.    xor   ch, ch
  2736.    jcxz  @1
  2737.    mov   al, WindowMax.X
  2738.    sub   al, dl
  2739.    inc   al
  2740.    cmp   cl, al
  2741.    JB    @2
  2742.    mov   cl, al
  2743. @2:jmp   CRTExtBlock
  2744. @1:
  2745. end;
  2746.  
  2747. procedure CRTExtDispatch; near; assembler; { Registers }
  2748. asm
  2749.    xor   cx, cx
  2750.    mov   dx, WindMin
  2751.    mov   cl, WindowMax.X
  2752.    sub   cl, dl
  2753.    inc   cx
  2754. @1:push  cx
  2755.    push  dx
  2756.    push  si
  2757.    call  CRTExtBlock
  2758.    pop   si
  2759.    pop   dx
  2760.    pop   cx
  2761.    inc   dh
  2762.    cmp   dh, WindowMax.Y
  2763.    jbe   @1
  2764.    mov   sp, bp
  2765.    pop   bp
  2766.    retf  4 { !!! }
  2767. end;
  2768.  
  2769. procedure CRTExtWriteStr; near; assembler; { Registers }
  2770. asm
  2771.    push  ds
  2772.    mov   ah, [bp+6]
  2773.    lds   si, [bp+8]
  2774.    inc   si
  2775.    jc    @2
  2776. @1:lodsb
  2777.    mov   bx, ax
  2778.    call  TSync
  2779.    mov   ax, bx
  2780.    stosw
  2781.    sti
  2782.    loop  @1
  2783.    jmp   @3
  2784. @2:lodsb
  2785.    stosw
  2786.    loop  @2
  2787. @3:pop   ds
  2788. end;
  2789.  
  2790. procedure CRTExtWriteChar; near; assembler; { Registers }
  2791. asm
  2792.    mov   al, [bp+8]
  2793.    mov   ah, [bp+6]
  2794.    jc    @2
  2795.    mov   bx, ax
  2796. @1:call  TSync
  2797.    mov   ax, bx
  2798.    stosw
  2799.    sti
  2800.    loop  @1
  2801.    jmp   @3
  2802. @2:rep   stosw
  2803. @3:
  2804. end;
  2805.  
  2806. procedure CRTExtWriteCharAttr; near; assembler; { Registers }
  2807. asm
  2808.    push  ds
  2809.    lds   si, [bp+6]
  2810.    jc    @2
  2811. @1:lodsw
  2812.    mov   bx, ax
  2813.    call  TSync
  2814.    mov   ax, bx
  2815.    stosw
  2816.    sti
  2817.    lodsb
  2818.    loop  @1
  2819.    jmp   @3
  2820. @2:movsw
  2821.    lodsb
  2822.    loop  @2
  2823. @3:pop   ds
  2824. end;
  2825.  
  2826. procedure WriteStrAt (x, y : Integer; s : String; Attr : TTextAttr); assembler;
  2827. asm
  2828.    les   bx, s
  2829.    mov   cl, es:[bx]
  2830.    mov   si, Offset @1
  2831.    call  CRTExtScrOp
  2832.    jmp   @2
  2833. @1:jmp   CRTExtWriteStr
  2834. @2:
  2835. end;
  2836.  
  2837. procedure WriteCharAt (x, y, Count : Integer; Ch : Char; Attr : TTextAttr); assembler;
  2838. asm
  2839.    mov   cx, Count
  2840.    mov   si, Offset @1
  2841.    call  CRTExtScrOp
  2842.    jmp   @2
  2843. @1:jmp   CRTExtWriteChar
  2844. @2:
  2845. end;
  2846.  
  2847. procedure WriteCharAttrAt (x, y, Count : Integer; CharAttr : PCharAttrs); assembler;
  2848. asm
  2849.    mov   cx, Count
  2850.    mov   si, Offset @1
  2851.    call  CRTExtScrOp
  2852.    jmp   @2
  2853. @1:jmp   CRTExtWriteCharAttr
  2854. @2:
  2855. end;
  2856.  
  2857. procedure ChangeTextAttr1 (x, y, Count : Integer; NewAttr, Dummy : TTextAttr); assembler;
  2858. asm
  2859.    mov   si, Offset @1
  2860.    mov   cx, Count
  2861.    call  CRTExtScrOp
  2862.    jmp   @5
  2863. @1:push  ds
  2864.    push  es
  2865.    pop   ds
  2866.    mov   bl, NewAttr
  2867.    mov   si, di
  2868.    jc    @3
  2869. @2:call  TSync
  2870.    lodsw
  2871.    mov   ah, bl
  2872.    stosw
  2873.    sti
  2874.    loop  @2
  2875.    jmp   @4
  2876. @3:lodsw
  2877.    mov   ah, bl
  2878.    stosw
  2879.    loop  @3
  2880. @4:pop   ds
  2881.    retn
  2882. @5:
  2883. end;
  2884.  
  2885. procedure ChangeTextAttr (x, y, Count : Integer; NewAttr : TTextAttr);
  2886. begin
  2887.   ChangeTextAttr1 (x, y, Count, NewAttr, 0)
  2888. end;
  2889.  
  2890. procedure FillWin (Ch : Char; Attr : TTextAttr); assembler;
  2891. asm
  2892.    mov   si, Offset @1
  2893.    jmp   CRTExtDispatch
  2894. @1:jmp   CRTExtWriteChar
  2895. end;
  2896.  
  2897. function WinSize : SizeType;
  2898. begin
  2899.   WinSize := 2 * GetYMax * GetXMax
  2900. end;
  2901.  
  2902. procedure CRTExtCopyWin; near; assembler; { Registers }
  2903. asm
  2904.    jc    @2
  2905. @1:lodsw
  2906.    mov   bx, ax
  2907.    call  TSync
  2908.    mov   ax, bx
  2909.    stosw
  2910.    sti
  2911.    loop  @1
  2912.    jmp   @3
  2913. @2:rep   movsw
  2914. @3:
  2915. end;
  2916.  
  2917. procedure ReadWin (var Buf); assembler;
  2918. asm
  2919.    mov   si, Offset @1
  2920.    jmp   CRTExtDispatch
  2921. @1:push  ds
  2922.    push  es
  2923.    pop   ds
  2924.    mov   si, di
  2925.    les   di, Buf
  2926.    call  CRTExtCopyWin
  2927.    mov   Word ptr Buf, di
  2928.    pop   ds
  2929.    retn
  2930. end;
  2931.  
  2932. procedure WriteWin (const Buf); assembler;
  2933. asm
  2934.    mov   si, Offset @1
  2935.    jmp   CRTExtDispatch
  2936. @1:push  ds
  2937.    lds   si, Buf
  2938.    call  CRTExtCopyWin
  2939.    mov   Word ptr Buf, si
  2940.    pop   ds
  2941.    retn
  2942. end;
  2943.  
  2944. procedure SaveWin (var State : WinState);
  2945. begin
  2946.   with State do
  2947.     begin
  2948.       GetWindow (x1, y1, x2, y2);
  2949.       NewX1 := x1;
  2950.       NewY1 := y1;
  2951.       NewX2 := x2;
  2952.       NewY2 := y2
  2953.     end;
  2954.   State.WhereX      := WhereX;
  2955.   State.WhereY      := WhereY;
  2956.   State.TextAttr    := TextAttr;
  2957.   State.CursorShape := GetCursorShape;
  2958.   State.TextMode    := - 1;
  2959.   State.BufSize     := 0;
  2960.   State.Buffer      := nil
  2961. end;
  2962.  
  2963. procedure MakeWin (var State : WinState; x1, y1, x2, y2 : Integer);
  2964. begin
  2965.   SaveWin (State);
  2966.   Window (x1, y1, x2, y2);
  2967.   with State do GetWindow (NewX1, NewY1, NewX2, NewY2);
  2968.   State.BufSize := WinSize;
  2969.   GetMem (State.Buffer, State.BufSize);
  2970.   ReadWin (State.Buffer^)
  2971. end;
  2972.  
  2973. procedure SaveScreen (var State : WinState);
  2974. begin
  2975.   MakeWin (State, 1, 1, ScreenSize.X, ScreenSize.Y);
  2976.   State.TextMode := LastMode
  2977. end;
  2978.  
  2979. procedure RestoreWin (var State : WinState);
  2980. begin
  2981.   if State.TextMode <> - 1 then
  2982.     begin
  2983.       if State.TextMode <> LastMode then TextMode (State.TextMode);
  2984.       Window (1, 1, ScreenSize.X, ScreenSize.Y)
  2985.     end;
  2986.   if State.Buffer <> nil then
  2987.     begin
  2988.       with State do Window (NewX1, NewY1, NewX2, NewY2);
  2989.       WriteWin (State.Buffer^);
  2990.       FreeMem (State.Buffer, State.BufSize);
  2991.       State.BufSize := 0;
  2992.       State.Buffer := nil
  2993.     end;
  2994.   with State do Window (x1, y1, x2, y2);
  2995.   GotoXY (State.WhereX, State.WhereY);
  2996.   TextAttr := State.TextAttr;
  2997.   SetCursorShape (State.CursorShape)
  2998. end;
  2999.  
  3000. function GetScreenSeg : Word; assembler;
  3001. asm
  3002.    push es
  3003.    mov  es, Seg0040
  3004.    mov  ax, SegB800
  3005.    cmp  byte ptr es:[$49], 7
  3006.    jne  @1
  3007.    mov  ax, SegB000
  3008. @1:pop  es
  3009. end;
  3010.  
  3011. procedure CRTExtInit;
  3012. begin
  3013.   ScreenBuffer := Ptr (GetScreenSeg, 0);
  3014.   if Seg (ScreenBuffer^) = SegB000
  3015.     then OrigCursor := $c0d
  3016.     else OrigCursor := $d0e;
  3017.   ScreenSize.X := WindowMax.X + 1;
  3018.   ScreenSize.Y := WindowMax.Y + 1;
  3019.   IsMonochrome := (LastMode and $ff) in MonoModes;
  3020.   NormalCursor
  3021. end;
  3022.  
  3023. const
  3024.   ReadKeyScan : Char = #0;
  3025.  
  3026. procedure CRTInit;
  3027. begin
  3028. end;
  3029.  
  3030. function KeyPressed : Boolean;
  3031. begin
  3032.   KeyPressed := (ReadKeyScan <> #0) or Crt.KeyPressed
  3033. end;
  3034.  
  3035. function ReadKey: Char;
  3036. var
  3037.   k : TKey;
  3038.   ch : Char;
  3039. begin
  3040.   if ReadKeyScan <> #0 then
  3041.     begin
  3042.       ReadKey := ReadKeyScan;
  3043.       ReadKeyScan := #0
  3044.     end
  3045.   else
  3046.     begin
  3047.       k := ReadKeyWord;
  3048.       ch := Key2Char (k);
  3049.       if ch = #0 then ReadKeyScan := Key2Scan (k);
  3050.       ReadKey := ch
  3051.     end
  3052. end;
  3053.  
  3054. procedure TextMode (Mode : Integer);
  3055. begin
  3056.   CRT.TextMode (Mode);
  3057.   CRTExtInit
  3058. end;
  3059.  
  3060. type
  3061.   PBigMemList = ^TBigMemList;
  3062.   TBigMemList = record
  3063.     Next : PBigMemList;
  3064.     p : PBigMem
  3065.   end;
  3066.  
  3067. const
  3068.   BigMemList : PBigMemList = nil;
  3069.  
  3070. {$ifdef MSDOS}
  3071. type
  3072.   TXMSData = record
  3073.     Length  : LongInt;
  3074.     SHandle : Word;
  3075.     SOffset : LongInt;
  3076.     DHandle : Word;
  3077.     DOffset : Longint
  3078.   end;
  3079.  
  3080. var
  3081.   XMSAdr, EMSPtr : Pointer;
  3082.  
  3083. procedure XMSError (ErrorCode : Byte);
  3084. begin
  3085.   RestoreTerminal (True);
  3086.   Writeln (StdErr, 'XMS error #', ErrorCode);
  3087.   Halt (125)
  3088. end;
  3089.  
  3090. function XMSInstalled : Boolean; assembler;
  3091. const Installed : Integer = - 1;
  3092. asm
  3093.    mov ax, Installed
  3094.    or  ax, ax
  3095.    jge @2
  3096.    mov ax, $4300
  3097.    int $2f
  3098.    cmp al, $80
  3099.    mov al, False
  3100.    jne @1
  3101.    mov ax, $4310
  3102.    int $2f
  3103.    mov Word ptr XMSAdr, bx
  3104.    mov Word ptr XMSAdr + 2, es
  3105.    mov al, True
  3106. @1:mov Installed, ax
  3107. @2:
  3108. end;
  3109.  
  3110. function XMSMaxAvail : Word; assembler;
  3111. asm
  3112.    mov  ah, 8
  3113.    call [XMSAdr]
  3114.    or   ax, ax
  3115.    jne  @1
  3116.    cmp  bl, $a0
  3117.    je   @1
  3118.    push bx
  3119.    call XMSError
  3120.    xor  ax, ax
  3121. @1:
  3122. end;
  3123.  
  3124. function XMSGetMem (Size : Word) : Word; assembler;
  3125. asm
  3126.    mov  ah, 9
  3127.    mov  dx, Size
  3128.    call [XMSAdr]
  3129.    or   ax, ax
  3130.    jne  @1
  3131.    push bx
  3132.    call XMSError
  3133.    xor  dx, dx
  3134. @1:mov  ax, dx
  3135. end;
  3136.  
  3137. procedure XMSFreeMem (Handle : Word); assembler;
  3138. asm
  3139.    mov  ah, $a
  3140.    mov  dx, Handle
  3141.    call [XMSAdr]
  3142.    or   ax, ax
  3143.    jne  @1
  3144.    push bx
  3145.    call XMSError
  3146. @1:
  3147. end;
  3148.  
  3149. procedure XMSCopy (var XMSData : TXMSData); assembler;
  3150. asm
  3151.    push ds
  3152.    pop  es
  3153.    push ds
  3154.    mov  ah, $b
  3155.    lds  si, XMSData
  3156.    call [es:XMSAdr]
  3157.    pop  ds
  3158.    or   ax, ax
  3159.    jne  @1
  3160.    push bx
  3161.    call XMSError
  3162. @1:
  3163. end;
  3164.  
  3165. procedure MoveToXMS (var Source; Handle : Word; BlockLength, Offset : LongInt);
  3166. var XMSData : TXMSData;
  3167. begin
  3168.   with XMSData do
  3169.     begin
  3170.       Length := BlockLength;
  3171.       SHandle := 0;
  3172.       Pointer (SOffset) := @Source;
  3173.       DHandle := Handle;
  3174.       DOffset := Offset
  3175.     end;
  3176.   XMSCopy (XMSData)
  3177. end;
  3178.  
  3179. procedure MoveFromXMS (Handle : Word; var Dest; BlockLength, Offset : LongInt);
  3180. var XMSData : TXMSData;
  3181. begin
  3182.   with XMSData do
  3183.     begin
  3184.       Length := BlockLength;
  3185.       SHandle := Handle;
  3186.       SOffset := Offset;
  3187.       DHandle := 0;
  3188.       Pointer (DOffset) := @Dest
  3189.     end;
  3190.   XMSCopy (XMSData)
  3191. end;
  3192.  
  3193. procedure EMSError (ErrorCode : Byte);
  3194. begin
  3195.   RestoreTerminal (True);
  3196.   Writeln (StdErr, 'EMS error #', ErrorCode);
  3197.   Halt (125)
  3198. end;
  3199.  
  3200. function EMSInstalled : Boolean; assembler;
  3201. const
  3202.   EMMName : array [1 .. 8] of Char = 'EMMXXXX0';
  3203.   Installed : Integer = - 1;
  3204. asm
  3205.    mov ax, Installed
  3206.    or  ax, ax
  3207.    jge @2
  3208.    mov  ax, $3567
  3209.    int  $21
  3210.    mov  si, Offset EMMName
  3211.    mov  di, $a
  3212.    mov  cx, 4
  3213.    cld
  3214.    repe cmpsw
  3215.    mov  ax, 0
  3216.    jne  @1
  3217.    mov  ah, $41
  3218.    int  $67
  3219.    or   ah, ah
  3220.    mov  ax, False
  3221.    jne  @1
  3222.    mov  Word ptr EMSPtr, ax
  3223.    mov  Word ptr EMSPtr + 2, bx
  3224.    mov  ax, True
  3225. @1:mov Installed, ax
  3226. @2:
  3227. end;
  3228.  
  3229. function EMSPages : Word; assembler;
  3230. asm
  3231.    mov  ah, $42
  3232.    int  $67
  3233.    or   ah, ah
  3234.    je   @1
  3235.    push ax
  3236.    call EMSError
  3237.    xor  bx, bx
  3238. @1:mov  ax, bx
  3239. end;
  3240.  
  3241. function EMSAllocatePages (Pages : Word) : Word; assembler;
  3242. asm
  3243.    mov  ah, $43
  3244.    mov  bx, Pages
  3245.    int  $67
  3246.    or   ah, ah
  3247.    je   @1
  3248.    push ax
  3249.    call EMSError
  3250.    xor  dx, dx
  3251. @1:mov  ax, dx
  3252. end;
  3253.  
  3254. procedure EMSDeallocatePages (Handle : Word); assembler;
  3255. asm
  3256.    mov  ah, $45
  3257.    mov  dx, Handle
  3258.    int  $67
  3259.    or   ah, ah
  3260.    je   @1
  3261.    push ax
  3262.    call EMSError
  3263. @1:
  3264. end;
  3265.  
  3266. procedure EMSMapPage (Handle, LPage, PPage : Word); assembler;
  3267. asm
  3268.    mov  ax, PPage
  3269.    mov  bx, LPage
  3270.    mov  dx, Handle
  3271.    mov  ah, $44
  3272.    int  $67
  3273.    or   ah, ah
  3274.    je   @1
  3275.    push ax
  3276.    call EMSError
  3277. @1:
  3278. end;
  3279. {$endif}
  3280.  
  3281. procedure MoveToBigMem (var Source; p : PBigMem; BlockNumber : SizeType);
  3282. var i : Word;
  3283. begin
  3284.   with p^ do
  3285.     {$ifdef MSDOS}
  3286.     if BlockNumber <= XMSBlocks then
  3287.       MoveToXMS (Source, XMSHandle, BlockSize, LongInt (1024) * XMSKBPerBlock * (BlockNumber - 1))
  3288.     else if BlockNumber <= XMSBlocks + EMSBlocks then
  3289.       begin
  3290.         for i := 0 to EMSPagesPerBlock - 1 do
  3291.           EMSMapPage (EMSHandle, EMSPagesPerBlock * (BlockNumber - XMSBlocks - 1) + i, i);
  3292.         Move (Source, EMSPtr^, BlockSize)
  3293.       end
  3294.     else
  3295.     {$endif}
  3296.       Move (Source, PConventional [BlockNumber {$ifdef MSDOS} - XMSBlocks - EMSBlocks {$endif}]^, BlockSize)
  3297. end;
  3298.  
  3299. procedure MoveFromBigMem (p : PBigMem; BlockNumber : SizeType; var Dest);
  3300. var i : Integer;
  3301. begin
  3302.   with p^ do
  3303.     {$ifdef MSDOS}
  3304.     if BlockNumber <= XMSBlocks then
  3305.       MoveFromXMS (XMSHandle, Dest, BlockSize, LongInt (1024) * XMSKBPerBlock * (BlockNumber - 1))
  3306.     else if BlockNumber <= XMSBlocks + EMSBlocks then
  3307.       begin
  3308.         for i := 0 to EMSPagesPerBlock - 1 do
  3309.           EMSMapPage (EMSHandle, EMSPagesPerBlock * (BlockNumber - XMSBlocks - 1) + i, i);
  3310.         Move (EMSPtr^, Dest, BlockSize)
  3311.       end
  3312.     else
  3313.     {$endif}
  3314.       Move (PConventional [BlockNumber {$ifdef MSDOS} - XMSBlocks - EMSBlocks {$endif}]^, Dest, BlockSize)
  3315. end;
  3316.  
  3317. function MapBigMem (p : PBigMem; BlockNumber : SizeType) : Pointer;
  3318. var i : Integer;
  3319. begin
  3320.   with p^ do
  3321.     begin
  3322.       if not Mappable then
  3323.         begin
  3324.           RestoreTerminal (True);
  3325.           Writeln (StdErr, 'attempt to map unmappable memory');
  3326.           Halt (125)
  3327.         end;
  3328.       if XMSBlocks <> 0 then
  3329.         begin
  3330.           RestoreTerminal (True);
  3331.           Writeln (StdErr, 'internal error in MapBigMem');
  3332.           Halt (125)
  3333.         end;
  3334.       {$ifdef MSDOS}
  3335.       if BlockNumber <= EMSBlocks then
  3336.         begin
  3337.           for i := 0 to EMSPagesPerBlock - 1 do
  3338.             EMSMapPage (EMSHandle, EMSPagesPerBlock * (BlockNumber - 1) + i, i);
  3339.           MapBigMem := EMSPtr
  3340.         end
  3341.       else
  3342.       {$endif}
  3343.         MapBigMem := PConventional [BlockNumber {$ifdef MSDOS} - EMSBlocks {$endif}]
  3344.     end
  3345. end;
  3346.  
  3347. function AllocateBigMem (WantedNumber, aBlockSize : SizeType; WantMappable : Boolean) : PBigMem;
  3348. var
  3349.   p : PBigMem;
  3350.   i : Integer;
  3351.   pl : PBigMemList;
  3352. begin
  3353.   New (p);
  3354.   with p^ do
  3355.     begin
  3356.       Mappable := WantMappable;
  3357.       BlockSize := aBlockSize;
  3358.       ConventionalBlocks := (MemAvail - $20000) div BlockSize;
  3359.       if ConventionalBlocks > High (PConventional) then ConventionalBlocks := High (PConventional);
  3360.       {$ifdef MSDOS}
  3361.       XMSHandle := 0;
  3362.       EMSHandle := 0;
  3363.       XMSBlocks := 0;
  3364.       EMSBlocks := 0;
  3365.       if (WantedNumber > ConventionalBlocks) and EMSInstalled then
  3366.         begin
  3367.           EMSPagesPerBlock := (LongInt (BlockSize) + $3fff) div $4000;
  3368.           EMSBlocks := EMSPages div EMSPagesPerBlock;
  3369.           if EMSBlocks > WantedNumber then EMSBlocks := WantedNumber;
  3370.           Dec (WantedNumber, EMSBlocks);
  3371.           if EMSBlocks <> 0 then EMSHandle := EMSAllocatePages (EMSPagesPerBlock * EMSBlocks)
  3372.         end;
  3373.       if not WantMappable and (WantedNumber > ConventionalBlocks) and XMSInstalled then
  3374.         begin
  3375.           XMSKBPerBlock := (LongInt (BlockSize) + $3ff) div $400;
  3376.           XMSBlocks := XMSMaxAvail div XMSKBPerBlock;
  3377.           if XMSBlocks > WantedNumber then XMSBlocks := WantedNumber;
  3378.           Dec (WantedNumber, XMSBlocks);
  3379.           if XMSBlocks <> 0 then XMSHandle := XMSGetMem (XMSKBPerBlock * XMSBlocks)
  3380.         end;
  3381.       {$endif}
  3382.       if ConventionalBlocks > WantedNumber then ConventionalBlocks := WantedNumber;
  3383.       for i := 1 to ConventionalBlocks do GetMem (PConventional [i], BlockSize);
  3384.       Number := ConventionalBlocks {$ifdef MSDOS} + XMSBlocks + EMSBlocks {$endif}
  3385.     end;
  3386.   New (pl);
  3387.   pl^.Next := BigMemList;
  3388.   pl^.p := p;
  3389.   BigMemList := pl;
  3390.   AllocateBigMem := p
  3391. end;
  3392.  
  3393. procedure DisposeBigMem (p : PBigMem);
  3394. var
  3395.   i : Integer;
  3396.   pl : PBigMemList;
  3397.   pp : ^PBigMemList;
  3398. begin
  3399.   with p^ do
  3400.     begin
  3401.       {$ifdef MSDOS}
  3402.       if XMSHandle <> 0 then XMSFreeMem (XMSHandle);
  3403.       if EMSHandle <> 0 then EMSDeallocatePages (EMSHandle);
  3404.       XMSHandle := 0;
  3405.       EMSHandle := 0;
  3406.       {$endif}
  3407.       for i := 1 to ConventionalBlocks do FreeMem (PConventional [i], BlockSize);
  3408.       ConventionalBlocks := 0
  3409.     end;
  3410.   pp := @BigMemList;
  3411.   while (pp^ <> nil) and (pp^^.p <> p) do pp := @pp^^.Next;
  3412.   if pp^ <> nil then
  3413.     begin
  3414.       pl := pp^;
  3415.       pp^ := pp^^.Next;
  3416.       Dispose (pl)
  3417.     end
  3418. end;
  3419.  
  3420. type
  3421.   TPtrRec = record Ofs, Sgm : Word end;
  3422.  
  3423. var
  3424.   TrapExitSave,
  3425.   TrapAddr : Pointer;
  3426.   TrapSP,
  3427.   TrapBP : Word;
  3428.  
  3429. {$S-}
  3430. procedure TrapExit; far;
  3431. begin
  3432.   if ErrorAddr <> nil then
  3433.     begin
  3434.       ExitProc := @TrapExit;
  3435.       TrappedErrorAddr := ErrorAddr;
  3436.       TrappedExitCode := ExitCode;
  3437.       ErrorAddr := nil;
  3438.       ExitCode := 0;
  3439.       asm
  3440.          mov  sp, TrapSP
  3441.          mov  bp, TrapBP
  3442.          mov  al, 1
  3443.          jmp  [TrapAddr]
  3444.       end
  3445.     end
  3446.   else
  3447.     begin
  3448.       ExitProc := TrapExitSave;
  3449.       if TrappedErrorAddr <> nil then
  3450.         begin
  3451.           ErrorAddr := TrappedErrorAddr;
  3452.           ExitCode := TrappedExitCode
  3453.         end
  3454.     end
  3455. end;
  3456. {$S+}
  3457.  
  3458. function SetTrap : Boolean; far; assembler;
  3459. asm
  3460.    mov  ax, Offset TrapExit
  3461.    mov  dx, Seg TrapExit
  3462.    cmp  ExitProc.TPtrRec.Ofs, ax
  3463.    jne  @1
  3464.    cmp  ExitProc.TPtrRec.Sgm, dx
  3465.    je   @2
  3466. @1:xchg ExitProc.TPtrRec.Ofs, ax
  3467.    xchg ExitProc.TPtrRec.Sgm, dx
  3468.    mov  TrapExitSave.TPtrRec.Ofs, ax
  3469.    mov  TrapExitSave.TPtrRec.Sgm, dx
  3470. @2:mov  TrapBP, bp
  3471.    mov  si, sp
  3472.    {$ifdef WINDOWS}
  3473.    add  si, 4
  3474.    add  TrapBP, 6
  3475.    {$endif}
  3476.    les  di, ss:[si]
  3477.    mov  TrapAddr.TPtrRec.Ofs, di
  3478.    mov  TrapAddr.TPtrRec.Sgm, es
  3479.    add  si, 4
  3480.    mov  TrapSP, si
  3481.    xor  ax, ax
  3482. end;
  3483.  
  3484. procedure TrapExec (p : TTrapProc);
  3485. begin
  3486.   p (SetTrap);
  3487.   if ExitProc = @TrapExit then ExitProc := TrapExitSave
  3488. end;
  3489.  
  3490. procedure GPCExit; far;
  3491. begin
  3492.   ExitProc := ExitSave;
  3493.   RestoreTerminal (True);
  3494.   while BigMemList <> nil do DisposeBigMem (BigMemList^.p) { Important! Removing this leads to system-wide memory leaks! }
  3495. end;
  3496.  
  3497. var
  3498.   i, j : Integer;
  3499.   h, m, s, s100 : Word;
  3500.  
  3501. begin
  3502.   Assign (StdErr, NullDeviceName);
  3503.   Rewrite (StdErr);
  3504.   TextRec (StdErr).Handle := 2;
  3505.   { Automatically check for a 80286 or higher in real mode if $G+ is set }
  3506.   {$ifdef MSDOS} {$ifopt G+}
  3507.   if Test8086 < 1 then
  3508.     begin
  3509.       Writeln (StdErr, 'This program needs at least an 80286 processor.');
  3510.       Halt (1)
  3511.     end;
  3512.   {$endif} {$endif}
  3513.   Randomize;
  3514.   ExitSave := ExitProc;
  3515.   ExitProc := @GPCExit;
  3516.   GetTime (h, m, s, s100);
  3517.   StartCPUTimeSeconds := (LongInt (h) * 60 + m) * 60 + s;
  3518.   StartCPUTimeMicroSeconds := 10000 * LongInt (s100);
  3519.   KBReadFunc := Mem [Seg0040 : $96] and $10;
  3520.   AssignCRT (CRTOutFile);
  3521.   Rewrite (CRTOutFile);
  3522.   CRTExtInit
  3523. end.
  3524.